From: Stephane Glondu Date: Tue, 21 Oct 2014 09:38:19 +0000 (+0200) Subject: Imported Upstream version 4.02.0 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~8 X-Git-Url: https://dgit.raspbian.org/%22http:/www.example.com/%22mailto:kde%40ewsoftware.de/%22style.css//%22node%24level1.html/%22/%22http:/www.example.com/%22mailto:kde%40ewsoftware.de/%22style.css/%22node%24level1.html/%22?a=commitdiff_plain;h=1a935ede44653d1dd2053cd1373558111f335925;p=ocaml.git Imported Upstream version 4.02.0 --- diff --git a/.depend b/.depend index 50b63374..9b6b9ffb 100644 --- a/.depend +++ b/.depend @@ -24,26 +24,32 @@ utils/terminfo.cmo : utils/terminfo.cmi utils/terminfo.cmx : utils/terminfo.cmi utils/warnings.cmo : utils/warnings.cmi utils/warnings.cmx : utils/warnings.cmi -parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ +parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/asttypes.cmi +parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/asttypes.cmi : parsing/location.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi parsing/longident.cmi : parsing/parse.cmi : parsing/parsetree.cmi -parsing/parser.cmi : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi +parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/asttypes.cmi parsing/printast.cmi : parsing/parsetree.cmi parsing/syntaxerr.cmi : parsing/location.cmi -parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi utils/config.cmi parsing/asttypes.cmi \ +parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi utils/config.cmi \ + utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ parsing/ast_mapper.cmi -parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx utils/config.cmx parsing/asttypes.cmi \ +parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ parsing/ast_mapper.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/lexer.cmi @@ -61,18 +67,22 @@ parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ - parsing/asttypes.cmi parsing/parser.cmi + parsing/asttypes.cmi parsing/ast_helper.cmi parsing/parser.cmi parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ - parsing/asttypes.cmi parsing/parser.cmi -parsing/pprintast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi parsing/pprintast.cmi -parsing/pprintast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx parsing/asttypes.cmi parsing/pprintast.cmi -parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi -parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi + parsing/asttypes.cmi parsing/ast_helper.cmx parsing/parser.cmi +parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ + parsing/pprintast.cmi +parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ + parsing/pprintast.cmi +parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ + parsing/printast.cmi +parsing/printast.cmx : parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ + parsing/printast.cmi parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi typing/annot.cmi : parsing/location.cmi @@ -93,8 +103,8 @@ typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ typing/ident.cmi typing/env.cmi typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ - typing/path.cmi typing/includecore.cmi typing/ident.cmi typing/env.cmi \ - typing/ctype.cmi + typing/path.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi typing/oprint.cmi : typing/outcometree.cmi @@ -120,29 +130,29 @@ typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/includecore.cmi typing/ident.cmi typing/env.cmi \ - parsing/asttypes.cmi + typing/includecore.cmi typing/ident.cmi typing/env.cmi typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - typing/env.cmi parsing/asttypes.cmi + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi typing/typedtreeMap.cmi : typing/typedtree.cmi -typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/includemod.cmi typing/ident.cmi typing/env.cmi -typing/types.cmi : typing/primitive.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/includemod.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi +typing/types.cmi : typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/env.cmi parsing/asttypes.cmi + typing/env.cmi parsing/asttypes.cmi parsing/ast_mapper.cmi typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ typing/ident.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ typing/ident.cmx typing/btype.cmi -typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ +typing/cmi_format.cmo : typing/types.cmi parsing/location.cmi \ utils/config.cmi typing/cmi_format.cmi -typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ +typing/cmi_format.cmx : typing/types.cmx parsing/location.cmx \ utils/config.cmx typing/cmi_format.cmi typing/cmt_format.cmo : typing/types.cmi typing/typedtreeMap.cmi \ typing/typedtree.cmi utils/misc.cmi parsing/location.cmi \ @@ -160,10 +170,10 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi -typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \ +typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/datarepr.cmi -typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \ +typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/datarepr.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ @@ -179,10 +189,10 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/env.cmi typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \ + typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi typing/envaux.cmi typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \ + typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : typing/ident.cmi typing/ident.cmx : typing/ident.cmi @@ -199,21 +209,25 @@ typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/includecore.cmi typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ - typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \ - utils/misc.cmi parsing/location.cmi typing/includecore.cmi \ - typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - utils/clflags.cmi typing/includemod.cmi + typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \ + typing/mtype.cmi utils/misc.cmi parsing/location.cmi \ + typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \ + typing/includemod.cmi typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ - typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \ - utils/misc.cmx parsing/location.cmx typing/includecore.cmx \ - typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - utils/clflags.cmx typing/includemod.cmi + typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \ + typing/mtype.cmx utils/misc.cmx parsing/location.cmx \ + typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ + typing/includemod.cmi typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/mtype.cmi typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ - typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/mtype.cmi + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/mtype.cmi typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ @@ -221,14 +235,14 @@ typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \ typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ - typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ typing/parmatch.cmi typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \ typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ - typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ typing/parmatch.cmi typing/path.cmo : typing/ident.cmi typing/path.cmi typing/path.cmx : typing/ident.cmx typing/path.cmi @@ -250,86 +264,90 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/printtyp.cmi -typing/printtyped.cmo : typing/typedtree.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - parsing/asttypes.cmi typing/printtyped.cmi -typing/printtyped.cmx : typing/typedtree.cmx typing/path.cmx \ - parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ - parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \ + typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi +typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \ + typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \ parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ - utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \ - typing/subst.cmi + utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ - utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \ - typing/subst.cmi + utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ - typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ - typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + typing/typecore.cmi parsing/syntaxerr.cmi typing/subst.cmi \ + typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/typeclass.cmi + parsing/ast_helper.cmi typing/typeclass.cmi typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \ typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ - typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \ - typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ + typing/typecore.cmx parsing/syntaxerr.cmx typing/subst.cmx \ + typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/typeclass.cmi + parsing/ast_helper.cmx typing/typeclass.cmi typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ - typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - typing/cmt_format.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi + typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ + typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \ + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi typing/annot.cmi typing/typecore.cmi typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ - typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - typing/cmt_format.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi + typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ + typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \ + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx typing/annot.cmi typing/typecore.cmi typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi typing/subst.cmi \ - typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ + typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/typedecl.cmi + parsing/ast_helper.cmi typing/typedecl.cmi typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ - typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ + typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/typedecl.cmi + parsing/ast_helper.cmx typing/typedecl.cmi typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ - utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtree.cmi + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ + typing/typedtree.cmi typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ - utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ - typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi -typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \ - typing/typedtreeIter.cmi -typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \ - typing/typedtreeIter.cmi + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ + typing/typedtree.cmi +typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \ + parsing/asttypes.cmi typing/typedtreeIter.cmi +typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \ + parsing/asttypes.cmi typing/typedtreeIter.cmi typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ - parsing/asttypes.cmi typing/typedtreeMap.cmi + typing/typedtreeMap.cmi typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ - parsing/asttypes.cmi typing/typedtreeMap.cmi + typing/typedtreeMap.cmi typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ @@ -337,8 +355,8 @@ typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ - typing/typemod.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_mapper.cmi typing/annot.cmi typing/typemod.cmi typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \ @@ -346,28 +364,30 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/includemod.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ - typing/typemod.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_mapper.cmx typing/annot.cmi typing/typemod.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi \ - parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ - parsing/asttypes.cmi typing/types.cmi + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi typing/types.cmi typing/types.cmx : typing/primitive.cmx typing/path.cmx \ - parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ - parsing/asttypes.cmi typing/types.cmi + parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/types.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ - typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/path.cmi \ - parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/typetexp.cmi + typing/typedtree.cmi utils/tbl.cmi parsing/syntaxerr.cmi \ + typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_mapper.cmi parsing/ast_helper.cmi typing/typetexp.cmi typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ - typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/path.cmx \ - parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/typetexp.cmi + typing/typedtree.cmx utils/tbl.cmx parsing/syntaxerr.cmx \ + typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_mapper.cmx parsing/ast_helper.cmx typing/typetexp.cmi bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi -bytecomp/bytepackager.cmi : typing/ident.cmi +bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi bytecomp/bytesections.cmi : bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi : @@ -377,7 +397,7 @@ bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi + bytecomp/lambda.cmi typing/ident.cmi bytecomp/meta.cmi : bytecomp/printinstr.cmi : bytecomp/instruct.cmi bytecomp/printlambda.cmi : bytecomp/lambda.cmi @@ -397,13 +417,13 @@ bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ - typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ - bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ - parsing/asttypes.cmi bytecomp/bytegen.cmi + typing/primitive.cmi utils/misc.cmi bytecomp/matching.cmi \ + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + utils/config.cmi parsing/asttypes.cmi bytecomp/bytegen.cmi bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ - typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ - bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \ - parsing/asttypes.cmi bytecomp/bytegen.cmi + typing/primitive.cmx utils/misc.cmx bytecomp/matching.cmx \ + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ + utils/config.cmx parsing/asttypes.cmi bytecomp/bytegen.cmi bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \ utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi @@ -421,33 +441,31 @@ bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ bytecomp/bytesections.cmx bytecomp/bytelink.cmi bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ - typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \ - bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytegen.cmi \ - bytecomp/bytepackager.cmi + typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \ + parsing/location.cmi bytecomp/instruct.cmi typing/ident.cmi \ + typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ + bytecomp/bytegen.cmi bytecomp/bytepackager.cmi bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ - typing/subst.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \ - bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \ - bytecomp/bytepackager.cmi -bytecomp/bytesections.cmo : utils/misc.cmi utils/config.cmi \ - bytecomp/bytesections.cmi -bytecomp/bytesections.cmx : utils/misc.cmx utils/config.cmx \ - bytecomp/bytesections.cmi + typing/subst.cmx bytecomp/printlambda.cmx typing/path.cmx utils/misc.cmx \ + parsing/location.cmx bytecomp/instruct.cmx typing/ident.cmx \ + typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ + bytecomp/bytegen.cmx bytecomp/bytepackager.cmi +bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi +bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ - bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ + parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \ + typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ - bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ - bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ + parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \ + typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ bytecomp/instruct.cmi @@ -492,24 +510,24 @@ bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ parsing/asttypes.cmi bytecomp/printlambda.cmi bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi -bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \ - typing/ident.cmi utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ - typing/ident.cmx utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ - bytecomp/simplif.cmi +bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi utils/misc.cmi \ + bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/simplif.cmi +bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx utils/misc.cmx \ + bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/simplif.cmi bytecomp/switch.cmo : bytecomp/switch.cmi bytecomp/switch.cmx : bytecomp/switch.cmi bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ - typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \ - bytecomp/symtable.cmi + typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytesections.cmi \ + parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ - typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ - typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \ - bytecomp/symtable.cmi + typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \ + parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ @@ -560,37 +578,39 @@ bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi -asmcomp/asmpackager.cmi : +asmcomp/asmpackager.cmi : typing/env.cmi asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi +asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ asmcomp/clambda.cmi asmcomp/cmx_format.cmi : asmcomp/clambda.cmi asmcomp/codegen.cmi : asmcomp/cmm.cmi asmcomp/coloring.cmi : asmcomp/comballoc.cmi : asmcomp/mach.cmi -asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmi +asmcomp/compilenv.cmi : typing/ident.cmi asmcomp/cmx_format.cmi \ + asmcomp/clambda.cmi +asmcomp/deadcode.cmi : asmcomp/mach.cmi asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi asmcomp/interf.cmi : asmcomp/mach.cmi -asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi asmcomp/liveness.cmi : asmcomp/mach.cmi -asmcomp/mach.cmi : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/arch.cmo +asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printclambda.cmi : asmcomp/clambda.cmi asmcomp/printcmm.cmi : asmcomp/cmm.cmi asmcomp/printlinear.cmi : asmcomp/linearize.cmi asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/reg.cmi : asmcomp/cmm.cmi +asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reload.cmi : asmcomp/mach.cmi asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi @@ -600,6 +620,13 @@ asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi : asmcomp/mach.cmi asmcomp/split.cmi : asmcomp/mach.cmi +asmcomp/strmatch.cmi : asmcomp/cmm.cmi +asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo +asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx +asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/CSEgen.cmi asmcomp/arch.cmo : asmcomp/arch.cmx : asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ @@ -608,27 +635,27 @@ asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \ - asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ - asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ - asmcomp/asmgen.cmi + asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \ + asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \ + asmcomp/closure.cmi utils/clflags.cmi asmcomp/CSE.cmo asmcomp/asmgen.cmi asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \ - asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ - asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ - asmcomp/asmgen.cmi -asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ + asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \ + asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \ + asmcomp/closure.cmx utils/clflags.cmx asmcomp/CSE.cmx asmcomp/asmgen.cmi +asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ + utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi -asmcomp/asmlibrarian.cmx : utils/misc.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/cmx_format.cmi utils/clflags.cmx \ - asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ +asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ + utils/clflags.cmx asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \ utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ @@ -655,29 +682,31 @@ asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ - utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ - asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ - parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi -asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ - utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ - asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ - parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi -asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ - asmcomp/cmm.cmi -asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ - asmcomp/cmm.cmi -asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ - typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ - asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ - typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ - asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/closure.cmi +asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ + utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ + asmcomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/cmmgen.cmi + asmcomp/closure.cmi +asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/arch.cmo asmcomp/cmm.cmi +asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/arch.cmx asmcomp/cmm.cmi +asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi \ + asmcomp/strmatch.cmi asmcomp/proc.cmi typing/primitive.cmi utils/misc.cmi \ + bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/cmmgen.cmi +asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx \ + asmcomp/strmatch.cmx asmcomp/proc.cmx typing/primitive.cmx utils/misc.cmx \ + bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/cmmgen.cmi asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ @@ -694,24 +723,30 @@ asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/arch.cmo asmcomp/comballoc.cmi asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ asmcomp/arch.cmx asmcomp/comballoc.cmi -asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi -asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ - asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi asmcomp/cmx_format.cmi \ + asmcomp/clambda.cmi asmcomp/compilenv.cmi +asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx asmcomp/cmx_format.cmi \ + asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/deadcode.cmi +asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/deadcode.cmi asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ asmcomp/debuginfo.cmi asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ - asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi + asmcomp/mach.cmi asmcomp/linearize.cmi bytecomp/lambda.cmi \ + asmcomp/emitaux.cmi asmcomp/debuginfo.cmi utils/config.cmi \ + asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ + asmcomp/emit.cmi asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ - asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi + asmcomp/mach.cmx asmcomp/linearize.cmx bytecomp/lambda.cmx \ + asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ + asmcomp/emit.cmi asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \ @@ -721,49 +756,53 @@ asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/interf.cmi asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/linearize.cmi + asmcomp/mach.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/linearize.cmi asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ - asmcomp/linearize.cmi + asmcomp/mach.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/linearize.cmi asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/liveness.cmi asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/liveness.cmi -asmcomp/mach.cmo : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/arch.cmo asmcomp/mach.cmi -asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ - asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi +asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ asmcomp/printclambda.cmi asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ asmcomp/printclambda.cmi -asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \ - asmcomp/cmm.cmi asmcomp/printcmm.cmi -asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \ - asmcomp/cmm.cmx asmcomp/printcmm.cmi +asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi +asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \ + asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \ - asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi + asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/debuginfo.cmi \ + asmcomp/printlinear.cmi asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \ - asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi + asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/debuginfo.cmx \ + asmcomp/printlinear.cmi asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ - asmcomp/printcmm.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi + asmcomp/printcmm.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ + asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/printmach.cmi asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ - asmcomp/printcmm.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi + asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ + asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/printmach.cmi asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ asmcomp/arch.cmo asmcomp/proc.cmi asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ asmcomp/arch.cmx asmcomp/proc.cmi -asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi +asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ @@ -781,19 +820,19 @@ asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ - asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \ - asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/selectgen.cmi + asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \ + typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ - asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \ - asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/selectgen.cmi + asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ + typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/selectgen.cmi asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \ - asmcomp/arch.cmo asmcomp/selection.cmi + asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ + asmcomp/selection.cmi asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \ - asmcomp/arch.cmx asmcomp/selection.cmi + asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ + asmcomp/selection.cmi asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -802,6 +841,10 @@ asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmi asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi +asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/strmatch.cmi +asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/strmatch.cmi driver/compenv.cmi : driver/compile.cmi : driver/compmisc.cmi : typing/env.cmi @@ -811,7 +854,7 @@ driver/main_args.cmi : driver/optcompile.cmi : driver/opterrors.cmi : driver/optmain.cmi : -driver/pparse.cmi : +driver/pparse.cmi : parsing/parsetree.cmi driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \ utils/config.cmi utils/clflags.cmi driver/compenv.cmi driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \ @@ -821,48 +864,36 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ - parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ - typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \ - utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ - utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi + utils/misc.cmi parsing/location.cmi typing/includemod.cmi typing/env.cmi \ + bytecomp/emitcode.cmi driver/compmisc.cmi driver/compenv.cmi \ + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \ parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ - parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ - typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \ - utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ - utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi -driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi -driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi -driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ - bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \ - driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ - typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ - typing/cmi_format.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ - bytecomp/bytelibrarian.cmi driver/errors.cmi -driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ - bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \ - driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ - typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ - typing/cmi_format.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ - bytecomp/bytelibrarian.cmx driver/errors.cmi + utils/misc.cmx parsing/location.cmx typing/includemod.cmx typing/env.cmx \ + bytecomp/emitcode.cmx driver/compmisc.cmx driver/compenv.cmx \ + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi +driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \ + parsing/asttypes.cmi driver/compmisc.cmi +driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \ + parsing/asttypes.cmi driver/compmisc.cmi +driver/errors.cmo : parsing/location.cmi driver/errors.cmi +driver/errors.cmx : parsing/location.cmx driver/errors.cmi driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi driver/errors.cmi utils/config.cmi \ - driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \ - utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compile.cmi driver/compenv.cmi utils/clflags.cmi \ + bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi driver/main.cmi driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ - parsing/location.cmx driver/errors.cmx utils/config.cmx \ - driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \ - utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compile.cmx driver/compenv.cmx utils/clflags.cmx \ + bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmx driver/main.cmi driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi @@ -870,52 +901,38 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ - parsing/pprintast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \ - parsing/location.cmi typing/includemod.cmi typing/env.cmi \ - utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \ - driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi \ - driver/optcompile.cmi + parsing/pprintast.cmi driver/pparse.cmi utils/misc.cmi \ + typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \ + asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \ + utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ - parsing/pprintast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \ - parsing/location.cmx typing/includemod.cmx typing/env.cmx \ - utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \ - driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx \ - driver/optcompile.cmi -driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ - bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \ - typing/cmi_format.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ - asmcomp/asmlibrarian.cmi asmcomp/asmgen.cmi driver/opterrors.cmi -driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ - bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \ - typing/cmi_format.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ - asmcomp/asmlibrarian.cmx asmcomp/asmgen.cmx driver/opterrors.cmi + parsing/pprintast.cmx driver/pparse.cmx utils/misc.cmx \ + typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \ + asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ + utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi +driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi +driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ - driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \ - driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \ - asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \ - asmcomp/arch.cmo driver/optmain.cmi + driver/optcompile.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compenv.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \ + asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \ + driver/optmain.cmi driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ - driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \ - driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \ - asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \ - asmcomp/arch.cmx driver/optmain.cmi -driver/pparse.cmo : utils/misc.cmi parsing/location.cmi utils/clflags.cmi \ - utils/ccomp.cmi driver/pparse.cmi -driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ - utils/ccomp.cmx driver/pparse.cmi + driver/optcompile.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \ + asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ + driver/optmain.cmi +driver/pparse.cmo : parsing/parsetree.cmi parsing/parse.cmi utils/misc.cmi \ + parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ + parsing/ast_mapper.cmi parsing/ast_helper.cmi driver/pparse.cmi +driver/pparse.cmx : parsing/parsetree.cmi parsing/parse.cmx utils/misc.cmx \ + parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ + parsing/ast_mapper.cmx parsing/ast_helper.cmx driver/pparse.cmi toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi toplevel/opttopdirs.cmi : parsing/longident.cmi @@ -958,9 +975,9 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ - driver/opterrors.cmi typing/oprint.cmi utils/misc.cmi \ - parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ - typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/ident.cmi \ + toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ toplevel/opttoploop.cmi @@ -970,34 +987,38 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \ parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ - driver/opterrors.cmx typing/oprint.cmx utils/misc.cmx \ - parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ - typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/ident.cmx \ + toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ toplevel/opttoploop.cmi toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ - toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ - utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi utils/config.cmi \ driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ - toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \ - utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx utils/config.cmx \ driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx -toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ - toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \ - typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \ - bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ - toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \ - typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \ - bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi +toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi toplevel/trace.cmi toplevel/toploop.cmi \ + bytecomp/symtable.cmi typing/printtyp.cmi typing/predef.cmi \ + typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + parsing/asttypes.cmi toplevel/topdirs.cmi +toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx toplevel/trace.cmx toplevel/toploop.cmx \ + bytecomp/symtable.cmx typing/printtyp.cmx typing/predef.cmx \ + typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx \ + utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + parsing/asttypes.cmi toplevel/topdirs.cmi toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ @@ -1007,10 +1028,11 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \ parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \ - typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \ + bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \ - bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi + bytecomp/bytegen.cmi typing/btype.cmi parsing/ast_helper.cmi \ + toplevel/toploop.cmi toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \ @@ -1020,18 +1042,19 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \ parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \ - typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \ + bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \ - bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi + bytecomp/bytegen.cmx typing/btype.cmx parsing/ast_helper.cmx \ + toplevel/toploop.cmi toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ - parsing/location.cmi driver/errors.cmi utils/config.cmi \ - driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi + parsing/location.cmi utils/config.cmi driver/compenv.cmi \ + utils/clflags.cmi toplevel/topmain.cmi toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ - parsing/location.cmx driver/errors.cmx utils/config.cmx \ - driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi + parsing/location.cmx utils/config.cmx driver/compenv.cmx \ + utils/clflags.cmx toplevel/topmain.cmi toplevel/topstart.cmo : toplevel/topmain.cmi toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..d36195a2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2758 @@ + +# / +/*.o +/*.a +/*.so +/*.obj +/*.lib +/*.dll +/*.cm[ioxat] +/*.cmx[as] +/*.cmti +/*.annot +/*.result +/*.byte +/*.native +/program +/*.exe +/*.exe.manifest +/.depend +/.depend.nt +/.DS_Store +/configure +/ocamlc +/ocamlc.opt +/expunge +/ocaml +/ocamlopt +/ocamlopt.opt +/ocamlcomp.sh +/ocamlcompopt.sh +/package-macosx +/ocamlnat + +# /asmcomp/ +/asmcomp/*.o +/asmcomp/*.a +/asmcomp/*.so +/asmcomp/*.obj +/asmcomp/*.lib +/asmcomp/*.dll +/asmcomp/*.cm[ioxat] +/asmcomp/*.cmx[as] +/asmcomp/*.cmti +/asmcomp/*.annot +/asmcomp/*.result +/asmcomp/*.byte +/asmcomp/*.native +/asmcomp/program +/asmcomp/*.exe +/asmcomp/*.exe.manifest +/asmcomp/.depend +/asmcomp/.depend.nt +/asmcomp/.DS_Store +/asmcomp/emit.ml +/asmcomp/arch.ml +/asmcomp/proc.ml +/asmcomp/selection.ml +/asmcomp/reload.ml +/asmcomp/scheduling.ml +/asmcomp/CSE.ml + +# /asmcomp/amd64/ +/asmcomp/amd64/*.o +/asmcomp/amd64/*.a +/asmcomp/amd64/*.so +/asmcomp/amd64/*.obj +/asmcomp/amd64/*.cm[ioxat] +/asmcomp/amd64/*.cmx[as] +/asmcomp/amd64/*.cmti +/asmcomp/amd64/*.annot +/asmcomp/amd64/*.result +/asmcomp/amd64/*.byte +/asmcomp/amd64/*.native +/asmcomp/amd64/program +/asmcomp/amd64/program.exe +/asmcomp/amd64/.depend +/asmcomp/amd64/.depend.nt +/asmcomp/amd64/.DS_Store + +# /asmrun/ +/asmrun/*.o +/asmrun/*.a +/asmrun/*.so +/asmrun/*.obj +/asmrun/*.lib +/asmrun/*.dll +/asmrun/*.cm[ioxat] +/asmrun/*.cmx[as] +/asmrun/*.cmti +/asmrun/*.annot +/asmrun/*.result +/asmrun/*.byte +/asmrun/*.native +/asmrun/program +/asmrun/*.exe +/asmrun/.depend +/asmrun/.depend.nt +/asmrun/.DS_Store +/asmrun/*.p.c +/asmrun/*.d.c +/asmrun/libasmrun.a +/asmrun/libasmrunp.a +/asmrun/main.c +/asmrun/misc.c +/asmrun/freelist.c +/asmrun/major_gc.c +/asmrun/minor_gc.c +/asmrun/memory.c +/asmrun/alloc.c +/asmrun/array.c +/asmrun/compare.c +/asmrun/ints.c +/asmrun/floats.c +/asmrun/str.c +/asmrun/io.c +/asmrun/extern.c +/asmrun/intern.c +/asmrun/hash.c +/asmrun/sys.c +/asmrun/parsing.c +/asmrun/gc_ctrl.c +/asmrun/terminfo.c +/asmrun/md5.c +/asmrun/obj.c +/asmrun/lexing.c +/asmrun/printexc.c +/asmrun/callback.c +/asmrun/weak.c +/asmrun/compact.c +/asmrun/finalise.c +/asmrun/custom.c +/asmrun/meta.c +/asmrun/globroots.c +/asmrun/unix.c +/asmrun/dynlink.c +/asmrun/signals.c +/asmrun/debugger.c +/asmrun/.depend.nt + +# /boot/ +/boot/*.o +/boot/*.a +/boot/*.so +/boot/*.obj +/boot/*.lib +/boot/*.dll +/boot/*.cm[ioxat] +/boot/*.cmx[as] +/boot/*.cmti +/boot/*.annot +/boot/*.result +/boot/*.byte +/boot/*.native +/boot/program +/boot/*.exe +/boot/*.exe.manifest +/boot/.depend +/boot/.depend.nt +/boot/.DS_Store +/boot/Saved +/boot/ocamlrun +/boot/ocamlrun.exe +/boot/ocamlyacc +/boot/ocamlyacc.exe +/boot/camlheader + +# /bytecomp/ +/bytecomp/*.o +/bytecomp/*.a +/bytecomp/*.so +/bytecomp/*.obj +/bytecomp/*.lib +/bytecomp/*.dll +/bytecomp/*.cm[ioxat] +/bytecomp/*.cmx[as] +/bytecomp/*.cmti +/bytecomp/*.annot +/bytecomp/*.result +/bytecomp/*.byte +/bytecomp/*.native +/bytecomp/program +/bytecomp/*.exe +/bytecomp/.depend +/bytecomp/.depend.nt +/bytecomp/.DS_Store +/bytecomp/runtimedef.ml +/bytecomp/opcodes.ml + +# /byterun/ +/byterun/*.o +/byterun/*.a +/byterun/*.so +/byterun/*.obj +/byterun/*.cm[ioxa] +/byterun/*.cmx[as] +/byterun/*.annot +/byterun/*.result +/byterun/*.byte +/byterun/*.native +/byterun/program +/byterun/program.exe +/byterun/.depend +/byterun/.depend.nt +/byterun/.DS_Store +/byterun/jumptbl.h +/byterun/primitives +/byterun/prims.c +/byterun/opnames.h +/byterun/version.h +/byterun/ocamlrun +/byterun/ocamlrun.exe +/byterun/ocamlrund +/byterun/ocamlrund.exe +/byterun/ld.conf +/byterun/interp.a.lst +/byterun/*.[sd]obj +/byterun/*.lib +/byterun/.gdb_history +/byterun/*.d.c +/byterun/*.pic.c + +# /compilerlibs/ +/compilerlibs/* + +# /config/ +/config/*.o +/config/*.a +/config/*.so +/config/*.obj +/config/*.lib +/config/*.dll +/config/*.cm[ioxat] +/config/*.cmx[as] +/config/*.cmti +/config/*.annot +/config/*.result +/config/*.byte +/config/*.native +/config/program +/config/*.exe +/config/*.exe.manifest +/config/.depend +/config/.depend.nt +/config/.DS_Store +/config/m.h +/config/s.h +/config/Makefile + +# /config/auto-aux/ +/config/auto-aux/*.o +/config/auto-aux/*.a +/config/auto-aux/*.so +/config/auto-aux/*.obj +/config/auto-aux/*.cm[ioxa] +/config/auto-aux/*.cmx[as] +/config/auto-aux/*.annot +/config/auto-aux/*.result +/config/auto-aux/*.byte +/config/auto-aux/*.native +/config/auto-aux/program +/config/auto-aux/.depend +/config/auto-aux/.depend.nt +/config/auto-aux/.DS_Store +/config/auto-aux/camlp4_config.ml + +# /config/gnu/ + +# /debugger/ +/debugger/*.o +/debugger/*.a +/debugger/*.so +/debugger/*.obj +/debugger/*.cm[ioxa] +/debugger/*.cmx[as] +/debugger/*.annot +/debugger/*.result +/debugger/*.byte +/debugger/*.native +/debugger/program +/debugger/program.exe +/debugger/.depend +/debugger/.depend.nt +/debugger/.DS_Store +/debugger/lexer.ml +/debugger/parser.ml +/debugger/parser.mli +/debugger/ocamldebug +/debugger/ocamldebug.exe +/debugger/dynlink.ml +/debugger/dynlink.mli + +# /driver/ +/driver/*.o +/driver/*.a +/driver/*.so +/driver/*.obj +/driver/*.lib +/driver/*.dll +/driver/*.cm[ioxat] +/driver/*.cmx[as] +/driver/*.cmti +/driver/*.annot +/driver/*.result +/driver/*.byte +/driver/*.native +/driver/program +/driver/*.exe +/driver/*.exe.manifest +/driver/.depend +/driver/.depend.nt +/driver/.DS_Store + +# /emacs/ +/emacs/*.o +/emacs/*.a +/emacs/*.so +/emacs/*.obj +/emacs/*.lib +/emacs/*.dll +/emacs/*.cm[ioxat] +/emacs/*.cmx[as] +/emacs/*.cmti +/emacs/*.annot +/emacs/*.result +/emacs/*.byte +/emacs/*.native +/emacs/program +/emacs/*.exe +/emacs/*.exe.manifest +/emacs/.depend +/emacs/.depend.nt +/emacs/.DS_Store +/emacs/ocamltags +/emacs/*.elc + +# /experimental/ + +# /experimental/garrigue/ +/experimental/garrigue/*.out +/experimental/garrigue/*.out2 + +# /lex/ +/lex/*.o +/lex/*.a +/lex/*.so +/lex/*.obj +/lex/*.lib +/lex/*.dll +/lex/*.cm[ioxat] +/lex/*.cmx[as] +/lex/*.cmti +/lex/*.annot +/lex/*.result +/lex/*.byte +/lex/*.native +/lex/program +/lex/*.exe +/lex/*.exe.manifest +/lex/.depend +/lex/.depend.nt +/lex/.DS_Store +/lex/parser.ml +/lex/parser.mli +/lex/lexer.ml +/lex/ocamllex +/lex/ocamllex.opt +/lex/parser.output + +# /ocamlbuild/ +/ocamlbuild/*.o +/ocamlbuild/*.a +/ocamlbuild/*.so +/ocamlbuild/*.obj +/ocamlbuild/*.lib +/ocamlbuild/*.dll +/ocamlbuild/*.cm[ioxat] +/ocamlbuild/*.cmx[as] +/ocamlbuild/*.cmti +/ocamlbuild/*.annot +/ocamlbuild/*.byte +/ocamlbuild/*.native +/ocamlbuild/ocamlbuild_config.ml +/ocamlbuild/lexers.ml +/ocamlbuild/glob_lexer.ml + +# /ocamldoc/ +/ocamldoc/*.o +/ocamldoc/*.a +/ocamldoc/*.so +/ocamldoc/*.obj +/ocamldoc/*.lib +/ocamldoc/*.dll +/ocamldoc/*.cm[ioxat] +/ocamldoc/*.cmx[as] +/ocamldoc/*.cmti +/ocamldoc/*.annot +/ocamldoc/*.result +/ocamldoc/*.byte +/ocamldoc/*.native +/ocamldoc/program +/ocamldoc/*.exe +/ocamldoc/.depend +/ocamldoc/.depend.nt +/ocamldoc/.DS_Store +/ocamldoc/ocamldoc +/ocamldoc/ocamldoc.opt +/ocamldoc/odoc_crc.ml +/ocamldoc/odoc_lexer.ml +/ocamldoc/odoc_ocamlhtml.ml +/ocamldoc/odoc_parser.ml +/ocamldoc/odoc_parser.mli +/ocamldoc/odoc_see_lexer.ml +/ocamldoc/odoc_text_lexer.ml +/ocamldoc/odoc_text_parser.ml +/ocamldoc/odoc_text_parser.mli +/ocamldoc/stdlib_man +/ocamldoc/*.output +/ocamldoc/test_stdlib +/ocamldoc/test_latex +/ocamldoc/test + +# /ocamldoc/generators/ +/ocamldoc/generators/*.o +/ocamldoc/generators/*.a +/ocamldoc/generators/*.so +/ocamldoc/generators/*.obj +/ocamldoc/generators/*.lib +/ocamldoc/generators/*.dll +/ocamldoc/generators/*.cm[ioxat] +/ocamldoc/generators/*.cmx[as] +/ocamldoc/generators/*.cmti +/ocamldoc/generators/*.annot +/ocamldoc/generators/*.result +/ocamldoc/generators/*.byte +/ocamldoc/generators/*.native +/ocamldoc/generators/program +/ocamldoc/generators/*.exe +/ocamldoc/generators/*.exe.manifest +/ocamldoc/generators/.depend +/ocamldoc/generators/.depend.nt +/ocamldoc/generators/.DS_Store + +# /otherlibs/ +/otherlibs/.depend +/otherlibs/configure +/otherlibs/ocamlc +/otherlibs/ocamlc.opt +/otherlibs/expunge +/otherlibs/ocaml +/otherlibs/ocamlopt +/otherlibs/ocamlopt.opt +/otherlibs/ocamlcomp.sh +/otherlibs/ocamlcompopt.sh +/otherlibs/package-macosx +/otherlibs/.DS_Store +/otherlibs/*.annot +/otherlibs/_boot_log1 +/otherlibs/_boot_log2 +/otherlibs/_build +/otherlibs/_log +/otherlibs/myocamlbuild_config.ml +/otherlibs/ocamlnat +/otherlibs/*.cm* +/otherlibs/*.o + +# /otherlibs/bigarray/ +/otherlibs/bigarray/*.o +/otherlibs/bigarray/*.a +/otherlibs/bigarray/*.so +/otherlibs/bigarray/*.obj +/otherlibs/bigarray/*.lib +/otherlibs/bigarray/*.dll +/otherlibs/bigarray/*.cm[ioxat] +/otherlibs/bigarray/*.cmx[as] +/otherlibs/bigarray/*.cmti +/otherlibs/bigarray/*.annot +/otherlibs/bigarray/*.result +/otherlibs/bigarray/*.byte +/otherlibs/bigarray/*.native +/otherlibs/bigarray/program +/otherlibs/bigarray/*.exe +/otherlibs/bigarray/.depend +/otherlibs/bigarray/.depend.nt +/otherlibs/bigarray/.DS_Store + +# /otherlibs/dynlink/ +/otherlibs/dynlink/*.o +/otherlibs/dynlink/*.a +/otherlibs/dynlink/*.so +/otherlibs/dynlink/*.obj +/otherlibs/dynlink/*.lib +/otherlibs/dynlink/*.dll +/otherlibs/dynlink/*.cm[ioxat] +/otherlibs/dynlink/*.cmx[as] +/otherlibs/dynlink/*.cmti +/otherlibs/dynlink/*.annot +/otherlibs/dynlink/*.result +/otherlibs/dynlink/*.byte +/otherlibs/dynlink/*.native +/otherlibs/dynlink/program +/otherlibs/dynlink/*.exe +/otherlibs/dynlink/.depend +/otherlibs/dynlink/.depend.nt +/otherlibs/dynlink/.DS_Store +/otherlibs/dynlink/extract_crc + +# /otherlibs/graph/ +/otherlibs/graph/*.o +/otherlibs/graph/*.a +/otherlibs/graph/*.so +/otherlibs/graph/*.obj +/otherlibs/graph/*.lib +/otherlibs/graph/*.dll +/otherlibs/graph/*.cm[ioxat] +/otherlibs/graph/*.cmx[as] +/otherlibs/graph/*.cmti +/otherlibs/graph/*.annot +/otherlibs/graph/*.result +/otherlibs/graph/*.byte +/otherlibs/graph/*.native +/otherlibs/graph/program +/otherlibs/graph/*.exe +/otherlibs/graph/*.exe.manifest +/otherlibs/graph/.depend +/otherlibs/graph/.depend.nt +/otherlibs/graph/.DS_Store + +# /otherlibs/num/ +/otherlibs/num/*.o +/otherlibs/num/*.a +/otherlibs/num/*.so +/otherlibs/num/*.obj +/otherlibs/num/*.lib +/otherlibs/num/*.dll +/otherlibs/num/*.cm[ioxat] +/otherlibs/num/*.cmx[as] +/otherlibs/num/*.cmti +/otherlibs/num/*.annot +/otherlibs/num/*.result +/otherlibs/num/*.byte +/otherlibs/num/*.native +/otherlibs/num/program +/otherlibs/num/*.exe +/otherlibs/num/.depend +/otherlibs/num/.depend.nt +/otherlibs/num/.DS_Store + +# /otherlibs/str/ +/otherlibs/str/*.o +/otherlibs/str/*.a +/otherlibs/str/*.so +/otherlibs/str/*.obj +/otherlibs/str/*.lib +/otherlibs/str/*.dll +/otherlibs/str/*.cm[ioxat] +/otherlibs/str/*.cmx[as] +/otherlibs/str/*.cmti +/otherlibs/str/*.annot +/otherlibs/str/*.result +/otherlibs/str/*.byte +/otherlibs/str/*.native +/otherlibs/str/program +/otherlibs/str/*.exe +/otherlibs/str/.depend +/otherlibs/str/.depend.nt +/otherlibs/str/.DS_Store + +# /otherlibs/systhreads/ +/otherlibs/systhreads/*.o +/otherlibs/systhreads/*.a +/otherlibs/systhreads/*.so +/otherlibs/systhreads/*.obj +/otherlibs/systhreads/*.lib +/otherlibs/systhreads/*.dll +/otherlibs/systhreads/*.cm[ioxat] +/otherlibs/systhreads/*.cmx[as] +/otherlibs/systhreads/*.cmti +/otherlibs/systhreads/*.annot +/otherlibs/systhreads/*.result +/otherlibs/systhreads/*.byte +/otherlibs/systhreads/*.native +/otherlibs/systhreads/program +/otherlibs/systhreads/*.exe +/otherlibs/systhreads/.depend +/otherlibs/systhreads/.depend.nt +/otherlibs/systhreads/.DS_Store +/otherlibs/systhreads/thread.ml + +# /otherlibs/threads/ +/otherlibs/threads/*.o +/otherlibs/threads/*.a +/otherlibs/threads/*.so +/otherlibs/threads/*.obj +/otherlibs/threads/*.lib +/otherlibs/threads/*.dll +/otherlibs/threads/*.cm[ioxat] +/otherlibs/threads/*.cmx[as] +/otherlibs/threads/*.cmti +/otherlibs/threads/*.annot +/otherlibs/threads/*.result +/otherlibs/threads/*.byte +/otherlibs/threads/*.native +/otherlibs/threads/program +/otherlibs/threads/*.exe +/otherlibs/threads/*.exe.manifest +/otherlibs/threads/.depend +/otherlibs/threads/.depend.nt +/otherlibs/threads/.DS_Store +/otherlibs/threads/marshal.mli +/otherlibs/threads/pervasives.mli +/otherlibs/threads/unix.mli + +# /otherlibs/unix/ +/otherlibs/unix/*.o +/otherlibs/unix/*.a +/otherlibs/unix/*.so +/otherlibs/unix/*.obj +/otherlibs/unix/*.lib +/otherlibs/unix/*.dll +/otherlibs/unix/*.cm[ioxat] +/otherlibs/unix/*.cmx[as] +/otherlibs/unix/*.cmti +/otherlibs/unix/*.annot +/otherlibs/unix/*.result +/otherlibs/unix/*.byte +/otherlibs/unix/*.native +/otherlibs/unix/program +/otherlibs/unix/*.exe +/otherlibs/unix/*.exe.manifest +/otherlibs/unix/.depend +/otherlibs/unix/.depend.nt +/otherlibs/unix/.DS_Store + +# /otherlibs/win32graph/ +/otherlibs/win32graph/*.o +/otherlibs/win32graph/*.a +/otherlibs/win32graph/*.so +/otherlibs/win32graph/*.obj +/otherlibs/win32graph/*.lib +/otherlibs/win32graph/*.dll +/otherlibs/win32graph/*.cm[ioxat] +/otherlibs/win32graph/*.cmx[as] +/otherlibs/win32graph/*.cmti +/otherlibs/win32graph/*.annot +/otherlibs/win32graph/*.result +/otherlibs/win32graph/*.byte +/otherlibs/win32graph/*.native +/otherlibs/win32graph/program +/otherlibs/win32graph/*.exe +/otherlibs/win32graph/.depend +/otherlibs/win32graph/.depend.nt +/otherlibs/win32graph/.DS_Store +/otherlibs/win32graph/graphics.ml +/otherlibs/win32graph/graphics.mli + +# /otherlibs/win32unix/ +/otherlibs/win32unix/*.o +/otherlibs/win32unix/*.a +/otherlibs/win32unix/*.so +/otherlibs/win32unix/*.obj +/otherlibs/win32unix/*.lib +/otherlibs/win32unix/*.dll +/otherlibs/win32unix/*.cm[ioxat] +/otherlibs/win32unix/*.cmx[as] +/otherlibs/win32unix/*.cmti +/otherlibs/win32unix/*.annot +/otherlibs/win32unix/*.result +/otherlibs/win32unix/*.byte +/otherlibs/win32unix/*.native +/otherlibs/win32unix/program +/otherlibs/win32unix/*.exe +/otherlibs/win32unix/.depend +/otherlibs/win32unix/.depend.nt +/otherlibs/win32unix/.DS_Store +/otherlibs/win32unix/unixLabels.ml* +/otherlibs/win32unix/unix.mli +/otherlibs/win32unix/unix.lib +/otherlibs/win32unix/access.c +/otherlibs/win32unix/addrofstr.c +/otherlibs/win32unix/chdir.c +/otherlibs/win32unix/chmod.c +/otherlibs/win32unix/cst2constr.c +/otherlibs/win32unix/cstringv.c +/otherlibs/win32unix/envir.c +/otherlibs/win32unix/execv.c +/otherlibs/win32unix/execve.c +/otherlibs/win32unix/execvp.c +/otherlibs/win32unix/exit.c +/otherlibs/win32unix/getaddrinfo.c +/otherlibs/win32unix/getcwd.c +/otherlibs/win32unix/gethost.c +/otherlibs/win32unix/gethostname.c +/otherlibs/win32unix/getnameinfo.c +/otherlibs/win32unix/getproto.c +/otherlibs/win32unix/getserv.c +/otherlibs/win32unix/gmtime.c +/otherlibs/win32unix/putenv.c +/otherlibs/win32unix/rmdir.c +/otherlibs/win32unix/socketaddr.c +/otherlibs/win32unix/strofaddr.c +/otherlibs/win32unix/time.c +/otherlibs/win32unix/unlink.c +/otherlibs/win32unix/utimes.c + +# /parsing/ +/parsing/*.o +/parsing/*.a +/parsing/*.so +/parsing/*.obj +/parsing/*.lib +/parsing/*.dll +/parsing/*.cm[ioxat] +/parsing/*.cmx[as] +/parsing/*.cmti +/parsing/*.annot +/parsing/*.result +/parsing/*.byte +/parsing/*.native +/parsing/program +/parsing/*.exe +/parsing/*.exe.manifest +/parsing/.depend +/parsing/.depend.nt +/parsing/.DS_Store +/parsing/parser.ml +/parsing/parser.mli +/parsing/lexer.ml +/parsing/lexer_tmp.mll +/parsing/lexer_tmp.ml +/parsing/linenum.ml +/parsing/parser.output +/parsing/parser.automaton +/parsing/parser.conflicts + +# /stdlib/ +/stdlib/*.o +/stdlib/*.a +/stdlib/*.so +/stdlib/*.obj +/stdlib/*.lib +/stdlib/*.dll +/stdlib/*.cm[ioxat] +/stdlib/*.cmx[as] +/stdlib/*.cmti +/stdlib/*.annot +/stdlib/*.result +/stdlib/*.byte +/stdlib/*.native +/stdlib/program +/stdlib/*.exe +/stdlib/.depend +/stdlib/.depend.nt +/stdlib/.DS_Store +/stdlib/camlheader +/stdlib/camlheaderd +/stdlib/camlheader_ur +/stdlib/labelled-* +/stdlib/caml +/stdlib/sys.ml + +# /testsuite/ +/testsuite/*.o +/testsuite/*.a +/testsuite/*.so +/testsuite/*.obj +/testsuite/*.cm[ioxa] +/testsuite/*.cmx[as] +/testsuite/*.annot +/testsuite/*.result +/testsuite/*.byte +/testsuite/*.native +/testsuite/program +/testsuite/.depend +/testsuite/.depend.nt +/testsuite/.DS_Store +/testsuite/_log + +# /testsuite/external/ +/testsuite/external/*.o +/testsuite/external/*.a +/testsuite/external/*.so +/testsuite/external/*.obj +/testsuite/external/*.lib +/testsuite/external/*.dll +/testsuite/external/*.cm[ioxat] +/testsuite/external/*.cmx[as] +/testsuite/external/*.cmti +/testsuite/external/*.annot +/testsuite/external/*.result +/testsuite/external/*.byte +/testsuite/external/*.native +/testsuite/external/program +/testsuite/external/*.exe +/testsuite/external/*.exe.manifest +/testsuite/external/.depend +/testsuite/external/.depend.nt +/testsuite/external/.DS_Store +/testsuite/external/*.tar.gz +/testsuite/external/*.tar.bz2 +/testsuite/external/*.tgz +/testsuite/external/*.tbz +/testsuite/external/*.zip +/testsuite/external/log-* +/testsuite/external/log_* +/testsuite/external/advi +/testsuite/external/advi-1.10.2 +/testsuite/external/altergo +/testsuite/external/alt-ergo-0.95.2 +/testsuite/external/binprot +/testsuite/external/bin_prot-109.30.00 +/testsuite/external/bitstring +/testsuite/external/ocaml-bitstring-2.0.3 +/testsuite/external/boomerang +/testsuite/external/boomerang-0.2 +/testsuite/external/calendar +/testsuite/external/calendar-2.03.2 +/testsuite/external/camlimages +/testsuite/external/camlimages-4.0.1 +/testsuite/external/camlpdf +/testsuite/external/camlpdf-0.5 +/testsuite/external/camlp4 +/testsuite/external/camlp4-trunk +/testsuite/external/camlp5 +/testsuite/external/camlp5-git +/testsuite/external/camlzip +/testsuite/external/camlzip-1.04 +/testsuite/external/camomile +/testsuite/external/camomile-0.8.4 +/testsuite/external/comparelib +/testsuite/external/comparelib-109.15.00 +/testsuite/external/compcert +/testsuite/external/compcert-1.13 +/testsuite/external/configfile +/testsuite/external/config-file-1.1 +/testsuite/external/coq +/testsuite/external/coq-8.4pl2 +/testsuite/external/core +/testsuite/external/core-109.37.00 +/testsuite/external/coreextended +/testsuite/external/core_extended-109.36.00 +/testsuite/external/corekernel +/testsuite/external/core_kernel-109.37.00 +/testsuite/external/cryptokit +/testsuite/external/cryptokit-1.6 +/testsuite/external/csv +/testsuite/external/csv-1.3.1 +/testsuite/external/customprintf +/testsuite/external/custom_printf-109.27.00 +/testsuite/external/dbm +/testsuite/external/camldbm-1.0 +/testsuite/external/expect +/testsuite/external/ocaml-expect-0.0.3 +/testsuite/external/extlib +/testsuite/external/extlib-1.5.2 +/testsuite/external/fieldslib +/testsuite/external/fieldslib-109.15.00 +/testsuite/external/fileutils +/testsuite/external/ocaml-fileutils-0.4.4 +/testsuite/external/findlib +/testsuite/external/findlib-1.4.1 +/testsuite/external/framac +/testsuite/external/frama-c-Oxygen-20120901 +/testsuite/external/geneweb +/testsuite/external/gw-6.05-src +/testsuite/external/herelib +/testsuite/external/herelib-109.35.00 +/testsuite/external/hevea +/testsuite/external/hevea-2.09 +/testsuite/external/kaputt +/testsuite/external/kaputt-1.2 +/testsuite/external/lablgtk +/testsuite/external/lablgtk-2.18.0 +/testsuite/external/lablgtkextras +/testsuite/external/lablgtkextras-1.3 +/testsuite/external/lwt +/testsuite/external/lwt-2.4.0 +/testsuite/external/menhir +/testsuite/external/menhir-20120123 +/testsuite/external/mldonkey +/testsuite/external/mldonkey-3.1.2 +/testsuite/external/mysql +/testsuite/external/ocaml-mysql-1.0.4 +/testsuite/external/oasis +/testsuite/external/oasis-0.3.0 +/testsuite/external/obrowser +/testsuite/external/obrowser-1.1.1 +/testsuite/external/ocamlgraph +/testsuite/external/ocamlgraph-1.8.2 +/testsuite/external/ocamlify +/testsuite/external/ocamlify-0.0.1 +/testsuite/external/ocamlmod +/testsuite/external/ocamlmod-0.0.3 +/testsuite/external/ocamlnet +/testsuite/external/ocamlnet-3.5.1 +/testsuite/external/ocamlscript +/testsuite/external/ocamlscript-2.0.3 +/testsuite/external/ocamlssl +/testsuite/external/ocaml-ssl-0.4.6 +/testsuite/external/ocamltext +/testsuite/external/ocaml-text-0.5 +/testsuite/external/ocgi +/testsuite/external/ocgi-0.5 +/testsuite/external/ocsigen +/testsuite/external/ocsigen-bundle-2.2.2 +/testsuite/external/odn +/testsuite/external/ocaml-data-notation-0.0.10 +/testsuite/external/omake +/testsuite/external/omake-0.9.8.6 +/testsuite/external/ounit +/testsuite/external/ounit-1.1.2 +/testsuite/external/paounit +/testsuite/external/pa_ounit-109.36.00 +/testsuite/external/pcre +/testsuite/external/pcre-ocaml-6.2.5 +/testsuite/external/pipebang +/testsuite/external/pipebang-109.28.00 +/testsuite/external/react +/testsuite/external/react-0.9.3 +/testsuite/external/res +/testsuite/external/res-3.2.0 +/testsuite/external/rss +/testsuite/external/ocamlrss-2.2.2 +/testsuite/external/sexplib +/testsuite/external/sexplib-109.15.00 +/testsuite/external/sks +/testsuite/external/sks-1.1.3 +/testsuite/external/sqlite +/testsuite/external/sqlite3-ocaml-2.0.1 +/testsuite/external/textutils +/testsuite/external/textutils-109.36.00 +/testsuite/external/typeconv +/testsuite/external/type_conv-109.28.00 +/testsuite/external/unison +/testsuite/external/unison-2.45.4 +/testsuite/external/variantslib +/testsuite/external/variantslib-109.15.00 +/testsuite/external/vsyml +/testsuite/external/vsyml-2010-04-06 +/testsuite/external/xmllight +/testsuite/external/xml-light.2.3 +/testsuite/external/xmlm +/testsuite/external/xmlm-1.1.0 +/testsuite/external/zarith +/testsuite/external/zarith-1.2.1 +/testsuite/external/zen +/testsuite/external/zen_2.3.2 +/testsuite/external/._ZEN_2.3.2 + +# /testsuite/interactive/ +/testsuite/interactive/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/_log +/testsuite/interactive/*.so +/testsuite/interactive/*.a +/testsuite/interactive/*.result +/testsuite/interactive/*.byte +/testsuite/interactive/*.native +/testsuite/interactive/program +/testsuite/interactive/*.cm* +/testsuite/interactive/*.o + +# /testsuite/interactive/lib-gc/ +/testsuite/interactive/lib-gc/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-gc/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-gc/_log +/testsuite/interactive/lib-gc/*.so +/testsuite/interactive/lib-gc/*.a +/testsuite/interactive/lib-gc/*.result +/testsuite/interactive/lib-gc/*.byte +/testsuite/interactive/lib-gc/*.native +/testsuite/interactive/lib-gc/program +/testsuite/interactive/lib-gc/*.cm* +/testsuite/interactive/lib-gc/*.o + +# /testsuite/interactive/lib-graph/ +/testsuite/interactive/lib-graph/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph/_log +/testsuite/interactive/lib-graph/*.so +/testsuite/interactive/lib-graph/*.a +/testsuite/interactive/lib-graph/*.result +/testsuite/interactive/lib-graph/*.byte +/testsuite/interactive/lib-graph/*.native +/testsuite/interactive/lib-graph/program +/testsuite/interactive/lib-graph/*.cm* +/testsuite/interactive/lib-graph/*.o + +# /testsuite/interactive/lib-graph-2/ +/testsuite/interactive/lib-graph-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph-2/_log +/testsuite/interactive/lib-graph-2/*.so +/testsuite/interactive/lib-graph-2/*.a +/testsuite/interactive/lib-graph-2/*.result +/testsuite/interactive/lib-graph-2/*.byte +/testsuite/interactive/lib-graph-2/*.native +/testsuite/interactive/lib-graph-2/program +/testsuite/interactive/lib-graph-2/*.cm* +/testsuite/interactive/lib-graph-2/*.o + +# /testsuite/interactive/lib-graph-3/ +/testsuite/interactive/lib-graph-3/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph-3/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph-3/_log +/testsuite/interactive/lib-graph-3/*.so +/testsuite/interactive/lib-graph-3/*.a +/testsuite/interactive/lib-graph-3/*.result +/testsuite/interactive/lib-graph-3/*.byte +/testsuite/interactive/lib-graph-3/*.native +/testsuite/interactive/lib-graph-3/program +/testsuite/interactive/lib-graph-3/*.cm* +/testsuite/interactive/lib-graph-3/*.o + +# /testsuite/interactive/lib-signals/ +/testsuite/interactive/lib-signals/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-signals/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-signals/_log +/testsuite/interactive/lib-signals/*.so +/testsuite/interactive/lib-signals/*.a +/testsuite/interactive/lib-signals/*.result +/testsuite/interactive/lib-signals/*.byte +/testsuite/interactive/lib-signals/*.native +/testsuite/interactive/lib-signals/program +/testsuite/interactive/lib-signals/*.cm* +/testsuite/interactive/lib-signals/*.o + +# /testsuite/lib/ +/testsuite/lib/*.o +/testsuite/lib/*.a +/testsuite/lib/*.so +/testsuite/lib/*.obj +/testsuite/lib/*.dll +/testsuite/lib/*.cm[ioxat] +/testsuite/lib/*.cmx[as] +/testsuite/lib/*.cmti +/testsuite/lib/*.annot +/testsuite/lib/*.result +/testsuite/lib/*.byte +/testsuite/lib/*.native +/testsuite/lib/program +/testsuite/lib/*.exe +/testsuite/lib/.depend +/testsuite/lib/.depend.nt +/testsuite/lib/.DS_Store + +# /testsuite/makefiles/ +/testsuite/makefiles/# svn propset -R svn:ignore -F .svnignore . +/testsuite/makefiles/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/makefiles/_log +/testsuite/makefiles/*.so +/testsuite/makefiles/*.a +/testsuite/makefiles/*.result +/testsuite/makefiles/*.byte +/testsuite/makefiles/*.native +/testsuite/makefiles/program +/testsuite/makefiles/*.cm* +/testsuite/makefiles/*.o + +# /testsuite/tests/ +/testsuite/tests/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/_log +/testsuite/tests/*.so +/testsuite/tests/*.a +/testsuite/tests/*.result +/testsuite/tests/*.byte +/testsuite/tests/*.native +/testsuite/tests/program +/testsuite/tests/*.cm* +/testsuite/tests/*.o + +# /testsuite/tests/asmcomp/ +/testsuite/tests/asmcomp/*.o +/testsuite/tests/asmcomp/*.a +/testsuite/tests/asmcomp/*.so +/testsuite/tests/asmcomp/*.obj +/testsuite/tests/asmcomp/*.lib +/testsuite/tests/asmcomp/*.dll +/testsuite/tests/asmcomp/*.cm[ioxat] +/testsuite/tests/asmcomp/*.cmx[as] +/testsuite/tests/asmcomp/*.cmti +/testsuite/tests/asmcomp/*.annot +/testsuite/tests/asmcomp/*.result +/testsuite/tests/asmcomp/*.byte +/testsuite/tests/asmcomp/*.native +/testsuite/tests/asmcomp/program +/testsuite/tests/asmcomp/*.exe +/testsuite/tests/asmcomp/*.exe.manifest +/testsuite/tests/asmcomp/.depend +/testsuite/tests/asmcomp/.depend.nt +/testsuite/tests/asmcomp/.DS_Store +/testsuite/tests/asmcomp/codegen +/testsuite/tests/asmcomp/parsecmm.ml +/testsuite/tests/asmcomp/parsecmm.mli +/testsuite/tests/asmcomp/lexcmm.ml +/testsuite/tests/asmcomp/*.s +/testsuite/tests/asmcomp/*.out +/testsuite/tests/asmcomp/*.out.dSYM + +# /testsuite/tests/backtrace/ +/testsuite/tests/backtrace/*.o +/testsuite/tests/backtrace/*.a +/testsuite/tests/backtrace/*.so +/testsuite/tests/backtrace/*.obj +/testsuite/tests/backtrace/*.lib +/testsuite/tests/backtrace/*.dll +/testsuite/tests/backtrace/*.cm[ioxat] +/testsuite/tests/backtrace/*.cmx[as] +/testsuite/tests/backtrace/*.cmti +/testsuite/tests/backtrace/*.annot +/testsuite/tests/backtrace/*.result +/testsuite/tests/backtrace/*.byte +/testsuite/tests/backtrace/*.native +/testsuite/tests/backtrace/program +/testsuite/tests/backtrace/*.exe +/testsuite/tests/backtrace/*.exe.manifest +/testsuite/tests/backtrace/.depend +/testsuite/tests/backtrace/.depend.nt +/testsuite/tests/backtrace/.DS_Store + +# /testsuite/tests/basic/ +/testsuite/tests/basic/*.o +/testsuite/tests/basic/*.a +/testsuite/tests/basic/*.so +/testsuite/tests/basic/*.obj +/testsuite/tests/basic/*.cm[ioxa] +/testsuite/tests/basic/*.cmx[as] +/testsuite/tests/basic/*.annot +/testsuite/tests/basic/*.result +/testsuite/tests/basic/*.byte +/testsuite/tests/basic/*.native +/testsuite/tests/basic/program +/testsuite/tests/basic/program.exe +/testsuite/tests/basic/.depend +/testsuite/tests/basic/.depend.nt +/testsuite/tests/basic/.DS_Store + +# /testsuite/tests/basic-float/ +/testsuite/tests/basic-float/*.o +/testsuite/tests/basic-float/*.a +/testsuite/tests/basic-float/*.so +/testsuite/tests/basic-float/*.obj +/testsuite/tests/basic-float/*.lib +/testsuite/tests/basic-float/*.dll +/testsuite/tests/basic-float/*.cm[ioxat] +/testsuite/tests/basic-float/*.cmx[as] +/testsuite/tests/basic-float/*.cmti +/testsuite/tests/basic-float/*.annot +/testsuite/tests/basic-float/*.result +/testsuite/tests/basic-float/*.byte +/testsuite/tests/basic-float/*.native +/testsuite/tests/basic-float/program +/testsuite/tests/basic-float/*.exe +/testsuite/tests/basic-float/*.exe.manifest +/testsuite/tests/basic-float/.depend +/testsuite/tests/basic-float/.depend.nt +/testsuite/tests/basic-float/.DS_Store + +# /testsuite/tests/basic-io/ +/testsuite/tests/basic-io/*.o +/testsuite/tests/basic-io/*.a +/testsuite/tests/basic-io/*.so +/testsuite/tests/basic-io/*.obj +/testsuite/tests/basic-io/*.lib +/testsuite/tests/basic-io/*.dll +/testsuite/tests/basic-io/*.cm[ioxat] +/testsuite/tests/basic-io/*.cmx[as] +/testsuite/tests/basic-io/*.cmti +/testsuite/tests/basic-io/*.annot +/testsuite/tests/basic-io/*.result +/testsuite/tests/basic-io/*.byte +/testsuite/tests/basic-io/*.native +/testsuite/tests/basic-io/program +/testsuite/tests/basic-io/*.exe +/testsuite/tests/basic-io/*.exe.manifest +/testsuite/tests/basic-io/.depend +/testsuite/tests/basic-io/.depend.nt +/testsuite/tests/basic-io/.DS_Store + +# /testsuite/tests/basic-io-2/ +/testsuite/tests/basic-io-2/*.o +/testsuite/tests/basic-io-2/*.a +/testsuite/tests/basic-io-2/*.so +/testsuite/tests/basic-io-2/*.obj +/testsuite/tests/basic-io-2/*.lib +/testsuite/tests/basic-io-2/*.dll +/testsuite/tests/basic-io-2/*.cm[ioxat] +/testsuite/tests/basic-io-2/*.cmx[as] +/testsuite/tests/basic-io-2/*.cmti +/testsuite/tests/basic-io-2/*.annot +/testsuite/tests/basic-io-2/*.result +/testsuite/tests/basic-io-2/*.byte +/testsuite/tests/basic-io-2/*.native +/testsuite/tests/basic-io-2/program +/testsuite/tests/basic-io-2/*.exe +/testsuite/tests/basic-io-2/*.exe.manifest +/testsuite/tests/basic-io-2/.depend +/testsuite/tests/basic-io-2/.depend.nt +/testsuite/tests/basic-io-2/.DS_Store + +# /testsuite/tests/basic-manyargs/ +/testsuite/tests/basic-manyargs/*.o +/testsuite/tests/basic-manyargs/*.a +/testsuite/tests/basic-manyargs/*.so +/testsuite/tests/basic-manyargs/*.obj +/testsuite/tests/basic-manyargs/*.lib +/testsuite/tests/basic-manyargs/*.dll +/testsuite/tests/basic-manyargs/*.cm[ioxat] +/testsuite/tests/basic-manyargs/*.cmx[as] +/testsuite/tests/basic-manyargs/*.cmti +/testsuite/tests/basic-manyargs/*.annot +/testsuite/tests/basic-manyargs/*.result +/testsuite/tests/basic-manyargs/*.byte +/testsuite/tests/basic-manyargs/*.native +/testsuite/tests/basic-manyargs/program +/testsuite/tests/basic-manyargs/*.exe +/testsuite/tests/basic-manyargs/*.exe.manifest +/testsuite/tests/basic-manyargs/.depend +/testsuite/tests/basic-manyargs/.depend.nt +/testsuite/tests/basic-manyargs/.DS_Store + +# /testsuite/tests/basic-modules/ +/testsuite/tests/basic-modules/*.o +/testsuite/tests/basic-modules/*.a +/testsuite/tests/basic-modules/*.so +/testsuite/tests/basic-modules/*.obj +/testsuite/tests/basic-modules/*.lib +/testsuite/tests/basic-modules/*.dll +/testsuite/tests/basic-modules/*.cm[ioxat] +/testsuite/tests/basic-modules/*.cmx[as] +/testsuite/tests/basic-modules/*.cmti +/testsuite/tests/basic-modules/*.annot +/testsuite/tests/basic-modules/*.result +/testsuite/tests/basic-modules/*.byte +/testsuite/tests/basic-modules/*.native +/testsuite/tests/basic-modules/program +/testsuite/tests/basic-modules/*.exe +/testsuite/tests/basic-modules/*.exe.manifest +/testsuite/tests/basic-modules/.depend +/testsuite/tests/basic-modules/.depend.nt +/testsuite/tests/basic-modules/.DS_Store + +# /testsuite/tests/basic-more/ +/testsuite/tests/basic-more/*.o +/testsuite/tests/basic-more/*.a +/testsuite/tests/basic-more/*.so +/testsuite/tests/basic-more/*.obj +/testsuite/tests/basic-more/*.cm[ioxa] +/testsuite/tests/basic-more/*.cmx[as] +/testsuite/tests/basic-more/*.annot +/testsuite/tests/basic-more/*.result +/testsuite/tests/basic-more/*.byte +/testsuite/tests/basic-more/*.native +/testsuite/tests/basic-more/program +/testsuite/tests/basic-more/program.exe +/testsuite/tests/basic-more/.depend +/testsuite/tests/basic-more/.depend.nt +/testsuite/tests/basic-more/.DS_Store + +# /testsuite/tests/basic-multdef/ +/testsuite/tests/basic-multdef/*.o +/testsuite/tests/basic-multdef/*.a +/testsuite/tests/basic-multdef/*.so +/testsuite/tests/basic-multdef/*.obj +/testsuite/tests/basic-multdef/*.lib +/testsuite/tests/basic-multdef/*.dll +/testsuite/tests/basic-multdef/*.cm[ioxat] +/testsuite/tests/basic-multdef/*.cmx[as] +/testsuite/tests/basic-multdef/*.cmti +/testsuite/tests/basic-multdef/*.annot +/testsuite/tests/basic-multdef/*.result +/testsuite/tests/basic-multdef/*.byte +/testsuite/tests/basic-multdef/*.native +/testsuite/tests/basic-multdef/program +/testsuite/tests/basic-multdef/*.exe +/testsuite/tests/basic-multdef/*.exe.manifest +/testsuite/tests/basic-multdef/.depend +/testsuite/tests/basic-multdef/.depend.nt +/testsuite/tests/basic-multdef/.DS_Store + +# /testsuite/tests/basic-private/ +/testsuite/tests/basic-private/*.o +/testsuite/tests/basic-private/*.a +/testsuite/tests/basic-private/*.so +/testsuite/tests/basic-private/*.obj +/testsuite/tests/basic-private/*.lib +/testsuite/tests/basic-private/*.dll +/testsuite/tests/basic-private/*.cm[ioxat] +/testsuite/tests/basic-private/*.cmx[as] +/testsuite/tests/basic-private/*.cmti +/testsuite/tests/basic-private/*.annot +/testsuite/tests/basic-private/*.result +/testsuite/tests/basic-private/*.byte +/testsuite/tests/basic-private/*.native +/testsuite/tests/basic-private/program +/testsuite/tests/basic-private/*.exe +/testsuite/tests/basic-private/*.exe.manifest +/testsuite/tests/basic-private/.depend +/testsuite/tests/basic-private/.depend.nt +/testsuite/tests/basic-private/.DS_Store + +# /testsuite/tests/callback/ +/testsuite/tests/callback/*.o +/testsuite/tests/callback/*.a +/testsuite/tests/callback/*.so +/testsuite/tests/callback/*.obj +/testsuite/tests/callback/*.cm[ioxa] +/testsuite/tests/callback/*.cmx[as] +/testsuite/tests/callback/*.annot +/testsuite/tests/callback/*.result +/testsuite/tests/callback/*.byte +/testsuite/tests/callback/*.native +/testsuite/tests/callback/program +/testsuite/tests/callback/program.exe +/testsuite/tests/callback/.depend +/testsuite/tests/callback/.depend.nt +/testsuite/tests/callback/.DS_Store + +# /testsuite/tests/embedded/ +/testsuite/tests/embedded/*.o +/testsuite/tests/embedded/*.a +/testsuite/tests/embedded/*.so +/testsuite/tests/embedded/*.obj +/testsuite/tests/embedded/*.lib +/testsuite/tests/embedded/*.dll +/testsuite/tests/embedded/*.cm[ioxat] +/testsuite/tests/embedded/*.cmx[as] +/testsuite/tests/embedded/*.cmti +/testsuite/tests/embedded/*.annot +/testsuite/tests/embedded/*.result +/testsuite/tests/embedded/*.byte +/testsuite/tests/embedded/*.native +/testsuite/tests/embedded/program +/testsuite/tests/embedded/*.exe +/testsuite/tests/embedded/*.exe.manifest +/testsuite/tests/embedded/.depend +/testsuite/tests/embedded/.depend.nt +/testsuite/tests/embedded/.DS_Store +/testsuite/tests/embedded/caml + +# /testsuite/tests/exotic-syntax/ +/testsuite/tests/exotic-syntax/*.o +/testsuite/tests/exotic-syntax/*.a +/testsuite/tests/exotic-syntax/*.so +/testsuite/tests/exotic-syntax/*.obj +/testsuite/tests/exotic-syntax/*.lib +/testsuite/tests/exotic-syntax/*.dll +/testsuite/tests/exotic-syntax/*.cm[ioxat] +/testsuite/tests/exotic-syntax/*.cmx[as] +/testsuite/tests/exotic-syntax/*.cmti +/testsuite/tests/exotic-syntax/*.annot +/testsuite/tests/exotic-syntax/*.result +/testsuite/tests/exotic-syntax/*.byte +/testsuite/tests/exotic-syntax/*.native +/testsuite/tests/exotic-syntax/program +/testsuite/tests/exotic-syntax/*.exe +/testsuite/tests/exotic-syntax/*.exe.manifest +/testsuite/tests/exotic-syntax/.depend +/testsuite/tests/exotic-syntax/.depend.nt +/testsuite/tests/exotic-syntax/.DS_Store + +# /testsuite/tests/formats-transition/ +/testsuite/tests/formats-transition/*.o +/testsuite/tests/formats-transition/*.a +/testsuite/tests/formats-transition/*.so +/testsuite/tests/formats-transition/*.obj +/testsuite/tests/formats-transition/*.lib +/testsuite/tests/formats-transition/*.dll +/testsuite/tests/formats-transition/*.cm[ioxat] +/testsuite/tests/formats-transition/*.cmx[as] +/testsuite/tests/formats-transition/*.cmti +/testsuite/tests/formats-transition/*.annot +/testsuite/tests/formats-transition/*.result +/testsuite/tests/formats-transition/*.byte +/testsuite/tests/formats-transition/*.native +/testsuite/tests/formats-transition/program +/testsuite/tests/formats-transition/*.exe +/testsuite/tests/formats-transition/*.exe.manifest +/testsuite/tests/formats-transition/.depend +/testsuite/tests/formats-transition/.depend.nt +/testsuite/tests/formats-transition/.DS_Store + +# /testsuite/tests/gc-roots/ +/testsuite/tests/gc-roots/*.o +/testsuite/tests/gc-roots/*.a +/testsuite/tests/gc-roots/*.so +/testsuite/tests/gc-roots/*.obj +/testsuite/tests/gc-roots/*.lib +/testsuite/tests/gc-roots/*.dll +/testsuite/tests/gc-roots/*.cm[ioxat] +/testsuite/tests/gc-roots/*.cmx[as] +/testsuite/tests/gc-roots/*.cmti +/testsuite/tests/gc-roots/*.annot +/testsuite/tests/gc-roots/*.result +/testsuite/tests/gc-roots/*.byte +/testsuite/tests/gc-roots/*.native +/testsuite/tests/gc-roots/program +/testsuite/tests/gc-roots/*.exe +/testsuite/tests/gc-roots/*.exe.manifest +/testsuite/tests/gc-roots/.depend +/testsuite/tests/gc-roots/.depend.nt +/testsuite/tests/gc-roots/.DS_Store + +# /testsuite/tests/letrec/ +/testsuite/tests/letrec/*.o +/testsuite/tests/letrec/*.a +/testsuite/tests/letrec/*.so +/testsuite/tests/letrec/*.obj +/testsuite/tests/letrec/*.cm[ioxa] +/testsuite/tests/letrec/*.cmx[as] +/testsuite/tests/letrec/*.annot +/testsuite/tests/letrec/*.result +/testsuite/tests/letrec/*.byte +/testsuite/tests/letrec/*.native +/testsuite/tests/letrec/program +/testsuite/tests/letrec/program.exe +/testsuite/tests/letrec/.depend +/testsuite/tests/letrec/.depend.nt +/testsuite/tests/letrec/.DS_Store + +# /testsuite/tests/lib-bigarray/ +/testsuite/tests/lib-bigarray/*.o +/testsuite/tests/lib-bigarray/*.a +/testsuite/tests/lib-bigarray/*.so +/testsuite/tests/lib-bigarray/*.obj +/testsuite/tests/lib-bigarray/*.lib +/testsuite/tests/lib-bigarray/*.dll +/testsuite/tests/lib-bigarray/*.cm[ioxat] +/testsuite/tests/lib-bigarray/*.cmx[as] +/testsuite/tests/lib-bigarray/*.cmti +/testsuite/tests/lib-bigarray/*.annot +/testsuite/tests/lib-bigarray/*.result +/testsuite/tests/lib-bigarray/*.byte +/testsuite/tests/lib-bigarray/*.native +/testsuite/tests/lib-bigarray/program +/testsuite/tests/lib-bigarray/*.exe +/testsuite/tests/lib-bigarray/*.exe.manifest +/testsuite/tests/lib-bigarray/.depend +/testsuite/tests/lib-bigarray/.depend.nt +/testsuite/tests/lib-bigarray/.DS_Store + +# /testsuite/tests/lib-bigarray-2/ +/testsuite/tests/lib-bigarray-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/lib-bigarray-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/lib-bigarray-2/_log +/testsuite/tests/lib-bigarray-2/*.so +/testsuite/tests/lib-bigarray-2/*.a +/testsuite/tests/lib-bigarray-2/*.result +/testsuite/tests/lib-bigarray-2/*.byte +/testsuite/tests/lib-bigarray-2/*.native +/testsuite/tests/lib-bigarray-2/program +/testsuite/tests/lib-bigarray-2/*.cm* +/testsuite/tests/lib-bigarray-2/*.o + +# /testsuite/tests/lib-digest/ +/testsuite/tests/lib-digest/*.o +/testsuite/tests/lib-digest/*.a +/testsuite/tests/lib-digest/*.so +/testsuite/tests/lib-digest/*.obj +/testsuite/tests/lib-digest/*.lib +/testsuite/tests/lib-digest/*.dll +/testsuite/tests/lib-digest/*.cm[ioxat] +/testsuite/tests/lib-digest/*.cmx[as] +/testsuite/tests/lib-digest/*.cmti +/testsuite/tests/lib-digest/*.annot +/testsuite/tests/lib-digest/*.result +/testsuite/tests/lib-digest/*.byte +/testsuite/tests/lib-digest/*.native +/testsuite/tests/lib-digest/program +/testsuite/tests/lib-digest/*.exe +/testsuite/tests/lib-digest/*.exe.manifest +/testsuite/tests/lib-digest/.depend +/testsuite/tests/lib-digest/.depend.nt +/testsuite/tests/lib-digest/.DS_Store + +# /testsuite/tests/lib-dynlink-bytecode/ +/testsuite/tests/lib-dynlink-bytecode/*.o +/testsuite/tests/lib-dynlink-bytecode/*.a +/testsuite/tests/lib-dynlink-bytecode/*.so +/testsuite/tests/lib-dynlink-bytecode/*.obj +/testsuite/tests/lib-dynlink-bytecode/*.lib +/testsuite/tests/lib-dynlink-bytecode/*.dll +/testsuite/tests/lib-dynlink-bytecode/*.cm[ioxat] +/testsuite/tests/lib-dynlink-bytecode/*.cmx[as] +/testsuite/tests/lib-dynlink-bytecode/*.cmti +/testsuite/tests/lib-dynlink-bytecode/*.annot +/testsuite/tests/lib-dynlink-bytecode/*.result +/testsuite/tests/lib-dynlink-bytecode/*.byte +/testsuite/tests/lib-dynlink-bytecode/*.native +/testsuite/tests/lib-dynlink-bytecode/program +/testsuite/tests/lib-dynlink-bytecode/*.exe +/testsuite/tests/lib-dynlink-bytecode/*.exe.manifest +/testsuite/tests/lib-dynlink-bytecode/.depend +/testsuite/tests/lib-dynlink-bytecode/.depend.nt +/testsuite/tests/lib-dynlink-bytecode/.DS_Store +/testsuite/tests/lib-dynlink-bytecode/main +/testsuite/tests/lib-dynlink-bytecode/static +/testsuite/tests/lib-dynlink-bytecode/custom +/testsuite/tests/lib-dynlink-bytecode/custom.exe +/testsuite/tests/lib-dynlink-bytecode/marshal.data +/testsuite/tests/lib-dynlink-bytecode/caml + +# /testsuite/tests/lib-dynlink-csharp/ +/testsuite/tests/lib-dynlink-csharp/*.o +/testsuite/tests/lib-dynlink-csharp/*.a +/testsuite/tests/lib-dynlink-csharp/*.so +/testsuite/tests/lib-dynlink-csharp/*.obj +/testsuite/tests/lib-dynlink-csharp/*.lib +/testsuite/tests/lib-dynlink-csharp/*.dll +/testsuite/tests/lib-dynlink-csharp/*.cm[ioxat] +/testsuite/tests/lib-dynlink-csharp/*.cmx[as] +/testsuite/tests/lib-dynlink-csharp/*.cmti +/testsuite/tests/lib-dynlink-csharp/*.annot +/testsuite/tests/lib-dynlink-csharp/*.result +/testsuite/tests/lib-dynlink-csharp/*.byte +/testsuite/tests/lib-dynlink-csharp/*.native +/testsuite/tests/lib-dynlink-csharp/program +/testsuite/tests/lib-dynlink-csharp/*.exe +/testsuite/tests/lib-dynlink-csharp/*.exe.manifest +/testsuite/tests/lib-dynlink-csharp/.depend +/testsuite/tests/lib-dynlink-csharp/.depend.nt +/testsuite/tests/lib-dynlink-csharp/.DS_Store + +# /testsuite/tests/lib-dynlink-native/ +/testsuite/tests/lib-dynlink-native/*.o +/testsuite/tests/lib-dynlink-native/*.a +/testsuite/tests/lib-dynlink-native/*.so +/testsuite/tests/lib-dynlink-native/*.obj +/testsuite/tests/lib-dynlink-native/*.lib +/testsuite/tests/lib-dynlink-native/*.dll +/testsuite/tests/lib-dynlink-native/*.cm[ioxat] +/testsuite/tests/lib-dynlink-native/*.cmx[as] +/testsuite/tests/lib-dynlink-native/*.cmti +/testsuite/tests/lib-dynlink-native/*.annot +/testsuite/tests/lib-dynlink-native/*.result +/testsuite/tests/lib-dynlink-native/*.byte +/testsuite/tests/lib-dynlink-native/*.native +/testsuite/tests/lib-dynlink-native/program +/testsuite/tests/lib-dynlink-native/*.exe +/testsuite/tests/lib-dynlink-native/*.exe.manifest +/testsuite/tests/lib-dynlink-native/.depend +/testsuite/tests/lib-dynlink-native/.depend.nt +/testsuite/tests/lib-dynlink-native/.DS_Store +/testsuite/tests/lib-dynlink-native/mypack.pack.s +/testsuite/tests/lib-dynlink-native/mypack.pack.asm +/testsuite/tests/lib-dynlink-native/result +/testsuite/tests/lib-dynlink-native/main +/testsuite/tests/lib-dynlink-native/main.exe +/testsuite/tests/lib-dynlink-native/marshal.data +/testsuite/tests/lib-dynlink-native/caml + +# /testsuite/tests/lib-dynlink-native/sub/ +/testsuite/tests/lib-dynlink-native/sub/*.o +/testsuite/tests/lib-dynlink-native/sub/*.a +/testsuite/tests/lib-dynlink-native/sub/*.so +/testsuite/tests/lib-dynlink-native/sub/*.obj +/testsuite/tests/lib-dynlink-native/sub/*.lib +/testsuite/tests/lib-dynlink-native/sub/*.dll +/testsuite/tests/lib-dynlink-native/sub/*.cm[ioxat] +/testsuite/tests/lib-dynlink-native/sub/*.cmx[as] +/testsuite/tests/lib-dynlink-native/sub/*.cmti +/testsuite/tests/lib-dynlink-native/sub/*.annot +/testsuite/tests/lib-dynlink-native/sub/*.result +/testsuite/tests/lib-dynlink-native/sub/*.byte +/testsuite/tests/lib-dynlink-native/sub/*.native +/testsuite/tests/lib-dynlink-native/sub/program +/testsuite/tests/lib-dynlink-native/sub/*.exe +/testsuite/tests/lib-dynlink-native/sub/*.exe.manifest +/testsuite/tests/lib-dynlink-native/sub/.depend +/testsuite/tests/lib-dynlink-native/sub/.depend.nt +/testsuite/tests/lib-dynlink-native/sub/.DS_Store + +# /testsuite/tests/lib-format/ +/testsuite/tests/lib-format/*.o +/testsuite/tests/lib-format/*.a +/testsuite/tests/lib-format/*.so +/testsuite/tests/lib-format/*.obj +/testsuite/tests/lib-format/*.lib +/testsuite/tests/lib-format/*.dll +/testsuite/tests/lib-format/*.cm[ioxat] +/testsuite/tests/lib-format/*.cmx[as] +/testsuite/tests/lib-format/*.cmti +/testsuite/tests/lib-format/*.annot +/testsuite/tests/lib-format/*.result +/testsuite/tests/lib-format/*.byte +/testsuite/tests/lib-format/*.native +/testsuite/tests/lib-format/program +/testsuite/tests/lib-format/*.exe +/testsuite/tests/lib-format/*.exe.manifest +/testsuite/tests/lib-format/.depend +/testsuite/tests/lib-format/.depend.nt +/testsuite/tests/lib-format/.DS_Store + +# /testsuite/tests/lib-hashtbl/ +/testsuite/tests/lib-hashtbl/*.o +/testsuite/tests/lib-hashtbl/*.a +/testsuite/tests/lib-hashtbl/*.so +/testsuite/tests/lib-hashtbl/*.obj +/testsuite/tests/lib-hashtbl/*.cm[ioxa] +/testsuite/tests/lib-hashtbl/*.cmx[as] +/testsuite/tests/lib-hashtbl/*.annot +/testsuite/tests/lib-hashtbl/*.result +/testsuite/tests/lib-hashtbl/*.byte +/testsuite/tests/lib-hashtbl/*.native +/testsuite/tests/lib-hashtbl/program +/testsuite/tests/lib-hashtbl/program.exe +/testsuite/tests/lib-hashtbl/.depend +/testsuite/tests/lib-hashtbl/.depend.nt +/testsuite/tests/lib-hashtbl/.DS_Store + +# /testsuite/tests/lib-marshal/ +/testsuite/tests/lib-marshal/*.o +/testsuite/tests/lib-marshal/*.a +/testsuite/tests/lib-marshal/*.so +/testsuite/tests/lib-marshal/*.obj +/testsuite/tests/lib-marshal/*.lib +/testsuite/tests/lib-marshal/*.dll +/testsuite/tests/lib-marshal/*.cm[ioxat] +/testsuite/tests/lib-marshal/*.cmx[as] +/testsuite/tests/lib-marshal/*.cmti +/testsuite/tests/lib-marshal/*.annot +/testsuite/tests/lib-marshal/*.result +/testsuite/tests/lib-marshal/*.byte +/testsuite/tests/lib-marshal/*.native +/testsuite/tests/lib-marshal/program +/testsuite/tests/lib-marshal/*.exe +/testsuite/tests/lib-marshal/*.exe.manifest +/testsuite/tests/lib-marshal/.depend +/testsuite/tests/lib-marshal/.depend.nt +/testsuite/tests/lib-marshal/.DS_Store + +# /testsuite/tests/lib-num/ +/testsuite/tests/lib-num/*.o +/testsuite/tests/lib-num/*.a +/testsuite/tests/lib-num/*.so +/testsuite/tests/lib-num/*.obj +/testsuite/tests/lib-num/*.lib +/testsuite/tests/lib-num/*.dll +/testsuite/tests/lib-num/*.cm[ioxat] +/testsuite/tests/lib-num/*.cmx[as] +/testsuite/tests/lib-num/*.cmti +/testsuite/tests/lib-num/*.annot +/testsuite/tests/lib-num/*.result +/testsuite/tests/lib-num/*.byte +/testsuite/tests/lib-num/*.native +/testsuite/tests/lib-num/program +/testsuite/tests/lib-num/*.exe +/testsuite/tests/lib-num/*.exe.manifest +/testsuite/tests/lib-num/.depend +/testsuite/tests/lib-num/.depend.nt +/testsuite/tests/lib-num/.DS_Store + +# /testsuite/tests/lib-num-2/ +/testsuite/tests/lib-num-2/*.o +/testsuite/tests/lib-num-2/*.a +/testsuite/tests/lib-num-2/*.so +/testsuite/tests/lib-num-2/*.obj +/testsuite/tests/lib-num-2/*.cm[ioxa] +/testsuite/tests/lib-num-2/*.cmx[as] +/testsuite/tests/lib-num-2/*.annot +/testsuite/tests/lib-num-2/*.result +/testsuite/tests/lib-num-2/*.byte +/testsuite/tests/lib-num-2/*.native +/testsuite/tests/lib-num-2/program +/testsuite/tests/lib-num-2/program.exe +/testsuite/tests/lib-num-2/.depend +/testsuite/tests/lib-num-2/.depend.nt +/testsuite/tests/lib-num-2/.DS_Store + +# /testsuite/tests/lib-printf/ +/testsuite/tests/lib-printf/*.o +/testsuite/tests/lib-printf/*.a +/testsuite/tests/lib-printf/*.so +/testsuite/tests/lib-printf/*.obj +/testsuite/tests/lib-printf/*.lib +/testsuite/tests/lib-printf/*.dll +/testsuite/tests/lib-printf/*.cm[ioxat] +/testsuite/tests/lib-printf/*.cmx[as] +/testsuite/tests/lib-printf/*.cmti +/testsuite/tests/lib-printf/*.annot +/testsuite/tests/lib-printf/*.result +/testsuite/tests/lib-printf/*.byte +/testsuite/tests/lib-printf/*.native +/testsuite/tests/lib-printf/program +/testsuite/tests/lib-printf/*.exe +/testsuite/tests/lib-printf/*.exe.manifest +/testsuite/tests/lib-printf/.depend +/testsuite/tests/lib-printf/.depend.nt +/testsuite/tests/lib-printf/.DS_Store + +# /testsuite/tests/lib-random/ +/testsuite/tests/lib-random/*.o +/testsuite/tests/lib-random/*.a +/testsuite/tests/lib-random/*.so +/testsuite/tests/lib-random/*.obj +/testsuite/tests/lib-random/*.lib +/testsuite/tests/lib-random/*.dll +/testsuite/tests/lib-random/*.cm[ioxat] +/testsuite/tests/lib-random/*.cmx[as] +/testsuite/tests/lib-random/*.cmti +/testsuite/tests/lib-random/*.annot +/testsuite/tests/lib-random/*.result +/testsuite/tests/lib-random/*.byte +/testsuite/tests/lib-random/*.native +/testsuite/tests/lib-random/program +/testsuite/tests/lib-random/*.exe +/testsuite/tests/lib-random/*.exe.manifest +/testsuite/tests/lib-random/.depend +/testsuite/tests/lib-random/.depend.nt +/testsuite/tests/lib-random/.DS_Store + +# /testsuite/tests/lib-scanf/ +/testsuite/tests/lib-scanf/*.o +/testsuite/tests/lib-scanf/*.a +/testsuite/tests/lib-scanf/*.so +/testsuite/tests/lib-scanf/*.obj +/testsuite/tests/lib-scanf/*.lib +/testsuite/tests/lib-scanf/*.dll +/testsuite/tests/lib-scanf/*.cm[ioxat] +/testsuite/tests/lib-scanf/*.cmx[as] +/testsuite/tests/lib-scanf/*.cmti +/testsuite/tests/lib-scanf/*.annot +/testsuite/tests/lib-scanf/*.result +/testsuite/tests/lib-scanf/*.byte +/testsuite/tests/lib-scanf/*.native +/testsuite/tests/lib-scanf/program +/testsuite/tests/lib-scanf/*.exe +/testsuite/tests/lib-scanf/*.exe.manifest +/testsuite/tests/lib-scanf/.depend +/testsuite/tests/lib-scanf/.depend.nt +/testsuite/tests/lib-scanf/.DS_Store +/testsuite/tests/lib-scanf/tscanf_data + +# /testsuite/tests/lib-scanf-2/ +/testsuite/tests/lib-scanf-2/*.o +/testsuite/tests/lib-scanf-2/*.a +/testsuite/tests/lib-scanf-2/*.so +/testsuite/tests/lib-scanf-2/*.obj +/testsuite/tests/lib-scanf-2/*.lib +/testsuite/tests/lib-scanf-2/*.dll +/testsuite/tests/lib-scanf-2/*.cm[ioxat] +/testsuite/tests/lib-scanf-2/*.cmx[as] +/testsuite/tests/lib-scanf-2/*.cmti +/testsuite/tests/lib-scanf-2/*.annot +/testsuite/tests/lib-scanf-2/*.result +/testsuite/tests/lib-scanf-2/*.byte +/testsuite/tests/lib-scanf-2/*.native +/testsuite/tests/lib-scanf-2/program +/testsuite/tests/lib-scanf-2/*.exe +/testsuite/tests/lib-scanf-2/*.exe.manifest +/testsuite/tests/lib-scanf-2/.depend +/testsuite/tests/lib-scanf-2/.depend.nt +/testsuite/tests/lib-scanf-2/.DS_Store + +# /testsuite/tests/lib-set/ +/testsuite/tests/lib-set/*.o +/testsuite/tests/lib-set/*.a +/testsuite/tests/lib-set/*.so +/testsuite/tests/lib-set/*.obj +/testsuite/tests/lib-set/*.cm[ioxa] +/testsuite/tests/lib-set/*.cmx[as] +/testsuite/tests/lib-set/*.annot +/testsuite/tests/lib-set/*.result +/testsuite/tests/lib-set/*.byte +/testsuite/tests/lib-set/*.native +/testsuite/tests/lib-set/program +/testsuite/tests/lib-set/program.exe +/testsuite/tests/lib-set/.depend +/testsuite/tests/lib-set/.depend.nt +/testsuite/tests/lib-set/.DS_Store + +# /testsuite/tests/lib-str/ +/testsuite/tests/lib-str/*.o +/testsuite/tests/lib-str/*.a +/testsuite/tests/lib-str/*.so +/testsuite/tests/lib-str/*.obj +/testsuite/tests/lib-str/*.cm[ioxa] +/testsuite/tests/lib-str/*.cmx[as] +/testsuite/tests/lib-str/*.annot +/testsuite/tests/lib-str/*.result +/testsuite/tests/lib-str/*.byte +/testsuite/tests/lib-str/*.native +/testsuite/tests/lib-str/program +/testsuite/tests/lib-str/program.exe +/testsuite/tests/lib-str/.depend +/testsuite/tests/lib-str/.depend.nt +/testsuite/tests/lib-str/.DS_Store + +# /testsuite/tests/lib-stream/ +/testsuite/tests/lib-stream/*.o +/testsuite/tests/lib-stream/*.a +/testsuite/tests/lib-stream/*.so +/testsuite/tests/lib-stream/*.obj +/testsuite/tests/lib-stream/*.cm[ioxa] +/testsuite/tests/lib-stream/*.cmx[as] +/testsuite/tests/lib-stream/*.annot +/testsuite/tests/lib-stream/*.result +/testsuite/tests/lib-stream/*.byte +/testsuite/tests/lib-stream/*.native +/testsuite/tests/lib-stream/program +/testsuite/tests/lib-stream/program.exe +/testsuite/tests/lib-stream/.depend +/testsuite/tests/lib-stream/.depend.nt +/testsuite/tests/lib-stream/.DS_Store + +# /testsuite/tests/lib-systhreads/ +/testsuite/tests/lib-systhreads/*.o +/testsuite/tests/lib-systhreads/*.a +/testsuite/tests/lib-systhreads/*.so +/testsuite/tests/lib-systhreads/*.obj +/testsuite/tests/lib-systhreads/*.cm[ioxa] +/testsuite/tests/lib-systhreads/*.cmx[as] +/testsuite/tests/lib-systhreads/*.annot +/testsuite/tests/lib-systhreads/*.result +/testsuite/tests/lib-systhreads/*.byte +/testsuite/tests/lib-systhreads/*.native +/testsuite/tests/lib-systhreads/program +/testsuite/tests/lib-systhreads/program.exe +/testsuite/tests/lib-systhreads/.depend +/testsuite/tests/lib-systhreads/.depend.nt +/testsuite/tests/lib-systhreads/.DS_Store + +# /testsuite/tests/lib-threads/ +/testsuite/tests/lib-threads/*.o +/testsuite/tests/lib-threads/*.a +/testsuite/tests/lib-threads/*.so +/testsuite/tests/lib-threads/*.obj +/testsuite/tests/lib-threads/*.cm[ioxa] +/testsuite/tests/lib-threads/*.cmx[as] +/testsuite/tests/lib-threads/*.annot +/testsuite/tests/lib-threads/*.result +/testsuite/tests/lib-threads/*.byte +/testsuite/tests/lib-threads/*.native +/testsuite/tests/lib-threads/program +/testsuite/tests/lib-threads/program.exe +/testsuite/tests/lib-threads/.depend +/testsuite/tests/lib-threads/.depend.nt +/testsuite/tests/lib-threads/.DS_Store +/testsuite/tests/lib-threads/*.byt + +# /testsuite/tests/match-exception/ +/testsuite/tests/match-exception/*.o +/testsuite/tests/match-exception/*.a +/testsuite/tests/match-exception/*.so +/testsuite/tests/match-exception/*.obj +/testsuite/tests/match-exception/*.lib +/testsuite/tests/match-exception/*.dll +/testsuite/tests/match-exception/*.cm[ioxat] +/testsuite/tests/match-exception/*.cmx[as] +/testsuite/tests/match-exception/*.cmti +/testsuite/tests/match-exception/*.annot +/testsuite/tests/match-exception/*.result +/testsuite/tests/match-exception/*.byte +/testsuite/tests/match-exception/*.native +/testsuite/tests/match-exception/program +/testsuite/tests/match-exception/*.exe +/testsuite/tests/match-exception/*.exe.manifest +/testsuite/tests/match-exception/.depend +/testsuite/tests/match-exception/.depend.nt +/testsuite/tests/match-exception/.DS_Store + +# /testsuite/tests/match-exception-warnings/ +/testsuite/tests/match-exception-warnings/*.o +/testsuite/tests/match-exception-warnings/*.a +/testsuite/tests/match-exception-warnings/*.so +/testsuite/tests/match-exception-warnings/*.obj +/testsuite/tests/match-exception-warnings/*.lib +/testsuite/tests/match-exception-warnings/*.dll +/testsuite/tests/match-exception-warnings/*.cm[ioxat] +/testsuite/tests/match-exception-warnings/*.cmx[as] +/testsuite/tests/match-exception-warnings/*.cmti +/testsuite/tests/match-exception-warnings/*.annot +/testsuite/tests/match-exception-warnings/*.result +/testsuite/tests/match-exception-warnings/*.byte +/testsuite/tests/match-exception-warnings/*.native +/testsuite/tests/match-exception-warnings/program +/testsuite/tests/match-exception-warnings/*.exe +/testsuite/tests/match-exception-warnings/*.exe.manifest +/testsuite/tests/match-exception-warnings/.depend +/testsuite/tests/match-exception-warnings/.depend.nt +/testsuite/tests/match-exception-warnings/.DS_Store + +# /testsuite/tests/misc/ +/testsuite/tests/misc/*.o +/testsuite/tests/misc/*.a +/testsuite/tests/misc/*.so +/testsuite/tests/misc/*.obj +/testsuite/tests/misc/*.cm[ioxa] +/testsuite/tests/misc/*.cmx[as] +/testsuite/tests/misc/*.annot +/testsuite/tests/misc/*.result +/testsuite/tests/misc/*.byte +/testsuite/tests/misc/*.native +/testsuite/tests/misc/program +/testsuite/tests/misc/program.exe +/testsuite/tests/misc/.depend +/testsuite/tests/misc/.depend.nt +/testsuite/tests/misc/.DS_Store + +# /testsuite/tests/misc-kb/ +/testsuite/tests/misc-kb/*.o +/testsuite/tests/misc-kb/*.a +/testsuite/tests/misc-kb/*.so +/testsuite/tests/misc-kb/*.obj +/testsuite/tests/misc-kb/*.lib +/testsuite/tests/misc-kb/*.dll +/testsuite/tests/misc-kb/*.cm[ioxat] +/testsuite/tests/misc-kb/*.cmx[as] +/testsuite/tests/misc-kb/*.cmti +/testsuite/tests/misc-kb/*.annot +/testsuite/tests/misc-kb/*.result +/testsuite/tests/misc-kb/*.byte +/testsuite/tests/misc-kb/*.native +/testsuite/tests/misc-kb/program +/testsuite/tests/misc-kb/*.exe +/testsuite/tests/misc-kb/*.exe.manifest +/testsuite/tests/misc-kb/.depend +/testsuite/tests/misc-kb/.depend.nt +/testsuite/tests/misc-kb/.DS_Store + +# /testsuite/tests/misc-unsafe/ +/testsuite/tests/misc-unsafe/*.o +/testsuite/tests/misc-unsafe/*.a +/testsuite/tests/misc-unsafe/*.so +/testsuite/tests/misc-unsafe/*.obj +/testsuite/tests/misc-unsafe/*.cm[ioxa] +/testsuite/tests/misc-unsafe/*.cmx[as] +/testsuite/tests/misc-unsafe/*.annot +/testsuite/tests/misc-unsafe/*.result +/testsuite/tests/misc-unsafe/*.byte +/testsuite/tests/misc-unsafe/*.native +/testsuite/tests/misc-unsafe/program +/testsuite/tests/misc-unsafe/program.exe +/testsuite/tests/misc-unsafe/.depend +/testsuite/tests/misc-unsafe/.depend.nt +/testsuite/tests/misc-unsafe/.DS_Store + +# /testsuite/tests/prim-bigstring/ +/testsuite/tests/prim-bigstring/*.o +/testsuite/tests/prim-bigstring/*.a +/testsuite/tests/prim-bigstring/*.so +/testsuite/tests/prim-bigstring/*.obj +/testsuite/tests/prim-bigstring/*.lib +/testsuite/tests/prim-bigstring/*.dll +/testsuite/tests/prim-bigstring/*.cm[ioxat] +/testsuite/tests/prim-bigstring/*.cmx[as] +/testsuite/tests/prim-bigstring/*.cmti +/testsuite/tests/prim-bigstring/*.annot +/testsuite/tests/prim-bigstring/*.result +/testsuite/tests/prim-bigstring/*.byte +/testsuite/tests/prim-bigstring/*.native +/testsuite/tests/prim-bigstring/program +/testsuite/tests/prim-bigstring/*.exe +/testsuite/tests/prim-bigstring/*.exe.manifest +/testsuite/tests/prim-bigstring/.depend +/testsuite/tests/prim-bigstring/.depend.nt +/testsuite/tests/prim-bigstring/.DS_Store + +# /testsuite/tests/prim-bswap/ +/testsuite/tests/prim-bswap/*.o +/testsuite/tests/prim-bswap/*.a +/testsuite/tests/prim-bswap/*.so +/testsuite/tests/prim-bswap/*.obj +/testsuite/tests/prim-bswap/*.cm[ioxat] +/testsuite/tests/prim-bswap/*.cmx[as] +/testsuite/tests/prim-bswap/*.cmti +/testsuite/tests/prim-bswap/*.annot +/testsuite/tests/prim-bswap/*.result +/testsuite/tests/prim-bswap/*.byte +/testsuite/tests/prim-bswap/*.native +/testsuite/tests/prim-bswap/program +/testsuite/tests/prim-bswap/program.exe +/testsuite/tests/prim-bswap/.depend +/testsuite/tests/prim-bswap/.depend.nt +/testsuite/tests/prim-bswap/.DS_Store + +# /testsuite/tests/prim-revapply/ +/testsuite/tests/prim-revapply/*.o +/testsuite/tests/prim-revapply/*.a +/testsuite/tests/prim-revapply/*.so +/testsuite/tests/prim-revapply/*.obj +/testsuite/tests/prim-revapply/*.cm[ioxa] +/testsuite/tests/prim-revapply/*.cmx[as] +/testsuite/tests/prim-revapply/*.annot +/testsuite/tests/prim-revapply/*.result +/testsuite/tests/prim-revapply/*.byte +/testsuite/tests/prim-revapply/*.native +/testsuite/tests/prim-revapply/program +/testsuite/tests/prim-revapply/program.exe +/testsuite/tests/prim-revapply/.depend +/testsuite/tests/prim-revapply/.depend.nt +/testsuite/tests/prim-revapply/.DS_Store + +# /testsuite/tests/regression/pr5080-notes/ +/testsuite/tests/regression/pr5080-notes/*.o +/testsuite/tests/regression/pr5080-notes/*.a +/testsuite/tests/regression/pr5080-notes/*.so +/testsuite/tests/regression/pr5080-notes/*.obj +/testsuite/tests/regression/pr5080-notes/*.cm[ioxa] +/testsuite/tests/regression/pr5080-notes/*.cmx[as] +/testsuite/tests/regression/pr5080-notes/*.annot +/testsuite/tests/regression/pr5080-notes/*.result +/testsuite/tests/regression/pr5080-notes/*.byte +/testsuite/tests/regression/pr5080-notes/*.native +/testsuite/tests/regression/pr5080-notes/program +/testsuite/tests/regression/pr5080-notes/program.exe +/testsuite/tests/regression/pr5080-notes/.depend +/testsuite/tests/regression/pr5080-notes/.depend.nt +/testsuite/tests/regression/pr5080-notes/.DS_Store + +# /testsuite/tests/regression/pr5233/ +/testsuite/tests/regression/pr5233/*.o +/testsuite/tests/regression/pr5233/*.a +/testsuite/tests/regression/pr5233/*.so +/testsuite/tests/regression/pr5233/*.obj +/testsuite/tests/regression/pr5233/*.lib +/testsuite/tests/regression/pr5233/*.dll +/testsuite/tests/regression/pr5233/*.cm[ioxat] +/testsuite/tests/regression/pr5233/*.cmx[as] +/testsuite/tests/regression/pr5233/*.cmti +/testsuite/tests/regression/pr5233/*.annot +/testsuite/tests/regression/pr5233/*.result +/testsuite/tests/regression/pr5233/*.byte +/testsuite/tests/regression/pr5233/*.native +/testsuite/tests/regression/pr5233/program +/testsuite/tests/regression/pr5233/*.exe +/testsuite/tests/regression/pr5233/*.exe.manifest +/testsuite/tests/regression/pr5233/.depend +/testsuite/tests/regression/pr5233/.depend.nt +/testsuite/tests/regression/pr5233/.DS_Store + +# /testsuite/tests/regression/pr5757/ +/testsuite/tests/regression/pr5757/*.o +/testsuite/tests/regression/pr5757/*.a +/testsuite/tests/regression/pr5757/*.so +/testsuite/tests/regression/pr5757/*.obj +/testsuite/tests/regression/pr5757/*.lib +/testsuite/tests/regression/pr5757/*.dll +/testsuite/tests/regression/pr5757/*.cm[ioxat] +/testsuite/tests/regression/pr5757/*.cmx[as] +/testsuite/tests/regression/pr5757/*.cmti +/testsuite/tests/regression/pr5757/*.annot +/testsuite/tests/regression/pr5757/*.result +/testsuite/tests/regression/pr5757/*.byte +/testsuite/tests/regression/pr5757/*.native +/testsuite/tests/regression/pr5757/program +/testsuite/tests/regression/pr5757/*.exe +/testsuite/tests/regression/pr5757/*.exe.manifest +/testsuite/tests/regression/pr5757/.depend +/testsuite/tests/regression/pr5757/.depend.nt +/testsuite/tests/regression/pr5757/.DS_Store + +# /testsuite/tests/regression/pr6024/ +/testsuite/tests/regression/pr6024/*.o +/testsuite/tests/regression/pr6024/*.a +/testsuite/tests/regression/pr6024/*.so +/testsuite/tests/regression/pr6024/*.obj +/testsuite/tests/regression/pr6024/*.lib +/testsuite/tests/regression/pr6024/*.dll +/testsuite/tests/regression/pr6024/*.cm[ioxat] +/testsuite/tests/regression/pr6024/*.cmx[as] +/testsuite/tests/regression/pr6024/*.cmti +/testsuite/tests/regression/pr6024/*.annot +/testsuite/tests/regression/pr6024/*.result +/testsuite/tests/regression/pr6024/*.byte +/testsuite/tests/regression/pr6024/*.native +/testsuite/tests/regression/pr6024/program +/testsuite/tests/regression/pr6024/*.exe +/testsuite/tests/regression/pr6024/*.exe.manifest +/testsuite/tests/regression/pr6024/.depend +/testsuite/tests/regression/pr6024/.depend.nt +/testsuite/tests/regression/pr6024/.DS_Store + +# /testsuite/tests/runtime-errors/ +/testsuite/tests/runtime-errors/*.o +/testsuite/tests/runtime-errors/*.a +/testsuite/tests/runtime-errors/*.so +/testsuite/tests/runtime-errors/*.obj +/testsuite/tests/runtime-errors/*.lib +/testsuite/tests/runtime-errors/*.dll +/testsuite/tests/runtime-errors/*.cm[ioxat] +/testsuite/tests/runtime-errors/*.cmx[as] +/testsuite/tests/runtime-errors/*.cmti +/testsuite/tests/runtime-errors/*.annot +/testsuite/tests/runtime-errors/*.result +/testsuite/tests/runtime-errors/*.byte +/testsuite/tests/runtime-errors/*.native +/testsuite/tests/runtime-errors/program +/testsuite/tests/runtime-errors/*.exe +/testsuite/tests/runtime-errors/*.exe.manifest +/testsuite/tests/runtime-errors/.depend +/testsuite/tests/runtime-errors/.depend.nt +/testsuite/tests/runtime-errors/.DS_Store +/testsuite/tests/runtime-errors/*.bytecode + +# /testsuite/tests/tool-debugger/ +/testsuite/tests/tool-debugger/*.o +/testsuite/tests/tool-debugger/*.a +/testsuite/tests/tool-debugger/*.so +/testsuite/tests/tool-debugger/*.obj +/testsuite/tests/tool-debugger/*.lib +/testsuite/tests/tool-debugger/*.dll +/testsuite/tests/tool-debugger/*.cm[ioxat] +/testsuite/tests/tool-debugger/*.cmx[as] +/testsuite/tests/tool-debugger/*.cmti +/testsuite/tests/tool-debugger/*.annot +/testsuite/tests/tool-debugger/*.result +/testsuite/tests/tool-debugger/*.byte +/testsuite/tests/tool-debugger/*.native +/testsuite/tests/tool-debugger/program +/testsuite/tests/tool-debugger/*.exe +/testsuite/tests/tool-debugger/*.exe.manifest +/testsuite/tests/tool-debugger/.depend +/testsuite/tests/tool-debugger/.depend.nt +/testsuite/tests/tool-debugger/.DS_Store +/testsuite/tests/tool-debugger/compiler-libs + +# /testsuite/tests/tool-debugger/basic/ +/testsuite/tests/tool-debugger/basic/*.o +/testsuite/tests/tool-debugger/basic/*.a +/testsuite/tests/tool-debugger/basic/*.so +/testsuite/tests/tool-debugger/basic/*.obj +/testsuite/tests/tool-debugger/basic/*.lib +/testsuite/tests/tool-debugger/basic/*.dll +/testsuite/tests/tool-debugger/basic/*.cm[ioxat] +/testsuite/tests/tool-debugger/basic/*.cmx[as] +/testsuite/tests/tool-debugger/basic/*.cmti +/testsuite/tests/tool-debugger/basic/*.annot +/testsuite/tests/tool-debugger/basic/*.result +/testsuite/tests/tool-debugger/basic/*.byte +/testsuite/tests/tool-debugger/basic/*.native +/testsuite/tests/tool-debugger/basic/program +/testsuite/tests/tool-debugger/basic/*.exe +/testsuite/tests/tool-debugger/basic/*.exe.manifest +/testsuite/tests/tool-debugger/basic/.depend +/testsuite/tests/tool-debugger/basic/.depend.nt +/testsuite/tests/tool-debugger/basic/.DS_Store +/testsuite/tests/tool-debugger/basic/compiler-libs + +# /testsuite/tests/tool-debugger/find-artifacts/ +/testsuite/tests/tool-debugger/find-artifacts/*.o +/testsuite/tests/tool-debugger/find-artifacts/*.a +/testsuite/tests/tool-debugger/find-artifacts/*.so +/testsuite/tests/tool-debugger/find-artifacts/*.obj +/testsuite/tests/tool-debugger/find-artifacts/*.lib +/testsuite/tests/tool-debugger/find-artifacts/*.dll +/testsuite/tests/tool-debugger/find-artifacts/*.cm[ioxat] +/testsuite/tests/tool-debugger/find-artifacts/*.cmx[as] +/testsuite/tests/tool-debugger/find-artifacts/*.cmti +/testsuite/tests/tool-debugger/find-artifacts/*.annot +/testsuite/tests/tool-debugger/find-artifacts/*.result +/testsuite/tests/tool-debugger/find-artifacts/*.byte +/testsuite/tests/tool-debugger/find-artifacts/*.native +/testsuite/tests/tool-debugger/find-artifacts/program +/testsuite/tests/tool-debugger/find-artifacts/*.exe +/testsuite/tests/tool-debugger/find-artifacts/*.exe.manifest +/testsuite/tests/tool-debugger/find-artifacts/.depend +/testsuite/tests/tool-debugger/find-artifacts/.depend.nt +/testsuite/tests/tool-debugger/find-artifacts/.DS_Store +/testsuite/tests/tool-debugger/find-artifacts/compiler-libs +/testsuite/tests/tool-debugger/find-artifacts/out + +# /testsuite/tests/tool-lexyacc/ +/testsuite/tests/tool-lexyacc/*.o +/testsuite/tests/tool-lexyacc/*.a +/testsuite/tests/tool-lexyacc/*.so +/testsuite/tests/tool-lexyacc/*.obj +/testsuite/tests/tool-lexyacc/*.lib +/testsuite/tests/tool-lexyacc/*.dll +/testsuite/tests/tool-lexyacc/*.cm[ioxat] +/testsuite/tests/tool-lexyacc/*.cmx[as] +/testsuite/tests/tool-lexyacc/*.cmti +/testsuite/tests/tool-lexyacc/*.annot +/testsuite/tests/tool-lexyacc/*.result +/testsuite/tests/tool-lexyacc/*.byte +/testsuite/tests/tool-lexyacc/*.native +/testsuite/tests/tool-lexyacc/program +/testsuite/tests/tool-lexyacc/*.exe +/testsuite/tests/tool-lexyacc/*.exe.manifest +/testsuite/tests/tool-lexyacc/.depend +/testsuite/tests/tool-lexyacc/.depend.nt +/testsuite/tests/tool-lexyacc/.DS_Store +/testsuite/tests/tool-lexyacc/scanner.ml +/testsuite/tests/tool-lexyacc/grammar.mli +/testsuite/tests/tool-lexyacc/grammar.ml + +# /testsuite/tests/tool-ocaml/ +/testsuite/tests/tool-ocaml/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/tool-ocaml/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/tool-ocaml/_log +/testsuite/tests/tool-ocaml/*.so +/testsuite/tests/tool-ocaml/*.a +/testsuite/tests/tool-ocaml/*.result +/testsuite/tests/tool-ocaml/*.byte +/testsuite/tests/tool-ocaml/*.native +/testsuite/tests/tool-ocaml/program +/testsuite/tests/tool-ocaml/*.cm* +/testsuite/tests/tool-ocaml/*.o + +# /testsuite/tests/tool-ocamldoc/ +/testsuite/tests/tool-ocamldoc/*.o +/testsuite/tests/tool-ocamldoc/*.a +/testsuite/tests/tool-ocamldoc/*.so +/testsuite/tests/tool-ocamldoc/*.obj +/testsuite/tests/tool-ocamldoc/*.cm[ioxa] +/testsuite/tests/tool-ocamldoc/*.cmx[as] +/testsuite/tests/tool-ocamldoc/*.annot +/testsuite/tests/tool-ocamldoc/*.result +/testsuite/tests/tool-ocamldoc/*.byte +/testsuite/tests/tool-ocamldoc/*.native +/testsuite/tests/tool-ocamldoc/program +/testsuite/tests/tool-ocamldoc/.depend +/testsuite/tests/tool-ocamldoc/.depend.nt +/testsuite/tests/tool-ocamldoc/.DS_Store +/testsuite/tests/tool-ocamldoc/*.html +/testsuite/tests/tool-ocamldoc/*.sty +/testsuite/tests/tool-ocamldoc/*.css +/testsuite/tests/tool-ocamldoc/ocamldoc.out + +# /testsuite/tests/tool-toplevel/ +/testsuite/tests/tool-toplevel/*.o +/testsuite/tests/tool-toplevel/*.a +/testsuite/tests/tool-toplevel/*.so +/testsuite/tests/tool-toplevel/*.obj +/testsuite/tests/tool-toplevel/*.lib +/testsuite/tests/tool-toplevel/*.dll +/testsuite/tests/tool-toplevel/*.cm[ioxat] +/testsuite/tests/tool-toplevel/*.cmx[as] +/testsuite/tests/tool-toplevel/*.cmti +/testsuite/tests/tool-toplevel/*.annot +/testsuite/tests/tool-toplevel/*.result +/testsuite/tests/tool-toplevel/*.byte +/testsuite/tests/tool-toplevel/*.native +/testsuite/tests/tool-toplevel/program +/testsuite/tests/tool-toplevel/*.exe +/testsuite/tests/tool-toplevel/*.exe.manifest +/testsuite/tests/tool-toplevel/.depend +/testsuite/tests/tool-toplevel/.depend.nt +/testsuite/tests/tool-toplevel/.DS_Store + +# /testsuite/tests/typing-extensions/ +/testsuite/tests/typing-extensions/*.o +/testsuite/tests/typing-extensions/*.a +/testsuite/tests/typing-extensions/*.so +/testsuite/tests/typing-extensions/*.obj +/testsuite/tests/typing-extensions/*.lib +/testsuite/tests/typing-extensions/*.dll +/testsuite/tests/typing-extensions/*.cm[ioxat] +/testsuite/tests/typing-extensions/*.cmx[as] +/testsuite/tests/typing-extensions/*.cmti +/testsuite/tests/typing-extensions/*.annot +/testsuite/tests/typing-extensions/*.result +/testsuite/tests/typing-extensions/*.byte +/testsuite/tests/typing-extensions/*.native +/testsuite/tests/typing-extensions/program +/testsuite/tests/typing-extensions/*.exe +/testsuite/tests/typing-extensions/*.exe.manifest +/testsuite/tests/typing-extensions/.depend +/testsuite/tests/typing-extensions/.depend.nt +/testsuite/tests/typing-extensions/.DS_Store + +# /testsuite/tests/typing-fstclassmod/ +/testsuite/tests/typing-fstclassmod/*.o +/testsuite/tests/typing-fstclassmod/*.a +/testsuite/tests/typing-fstclassmod/*.so +/testsuite/tests/typing-fstclassmod/*.obj +/testsuite/tests/typing-fstclassmod/*.lib +/testsuite/tests/typing-fstclassmod/*.dll +/testsuite/tests/typing-fstclassmod/*.cm[ioxat] +/testsuite/tests/typing-fstclassmod/*.cmx[as] +/testsuite/tests/typing-fstclassmod/*.cmti +/testsuite/tests/typing-fstclassmod/*.annot +/testsuite/tests/typing-fstclassmod/*.result +/testsuite/tests/typing-fstclassmod/*.byte +/testsuite/tests/typing-fstclassmod/*.native +/testsuite/tests/typing-fstclassmod/program +/testsuite/tests/typing-fstclassmod/*.exe +/testsuite/tests/typing-fstclassmod/*.exe.manifest +/testsuite/tests/typing-fstclassmod/.depend +/testsuite/tests/typing-fstclassmod/.depend.nt +/testsuite/tests/typing-fstclassmod/.DS_Store + +# /testsuite/tests/typing-gadts/ +/testsuite/tests/typing-gadts/*.o +/testsuite/tests/typing-gadts/*.a +/testsuite/tests/typing-gadts/*.so +/testsuite/tests/typing-gadts/*.obj +/testsuite/tests/typing-gadts/*.cm[ioxa] +/testsuite/tests/typing-gadts/*.cmx[as] +/testsuite/tests/typing-gadts/*.annot +/testsuite/tests/typing-gadts/*.result +/testsuite/tests/typing-gadts/*.byte +/testsuite/tests/typing-gadts/*.native +/testsuite/tests/typing-gadts/program +/testsuite/tests/typing-gadts/.depend +/testsuite/tests/typing-gadts/.depend.nt +/testsuite/tests/typing-gadts/.DS_Store + +# /testsuite/tests/typing-implicit_unpack/ +/testsuite/tests/typing-implicit_unpack/*.o +/testsuite/tests/typing-implicit_unpack/*.a +/testsuite/tests/typing-implicit_unpack/*.so +/testsuite/tests/typing-implicit_unpack/*.obj +/testsuite/tests/typing-implicit_unpack/*.cm[ioxa] +/testsuite/tests/typing-implicit_unpack/*.cmx[as] +/testsuite/tests/typing-implicit_unpack/*.annot +/testsuite/tests/typing-implicit_unpack/*.result +/testsuite/tests/typing-implicit_unpack/*.byte +/testsuite/tests/typing-implicit_unpack/*.native +/testsuite/tests/typing-implicit_unpack/program +/testsuite/tests/typing-implicit_unpack/.depend +/testsuite/tests/typing-implicit_unpack/.depend.nt +/testsuite/tests/typing-implicit_unpack/.DS_Store + +# /testsuite/tests/typing-labels/ +/testsuite/tests/typing-labels/*.o +/testsuite/tests/typing-labels/*.a +/testsuite/tests/typing-labels/*.so +/testsuite/tests/typing-labels/*.obj +/testsuite/tests/typing-labels/*.cm[ioxa] +/testsuite/tests/typing-labels/*.cmx[as] +/testsuite/tests/typing-labels/*.annot +/testsuite/tests/typing-labels/*.result +/testsuite/tests/typing-labels/*.byte +/testsuite/tests/typing-labels/*.native +/testsuite/tests/typing-labels/program +/testsuite/tests/typing-labels/program.exe +/testsuite/tests/typing-labels/.depend +/testsuite/tests/typing-labels/.depend.nt +/testsuite/tests/typing-labels/.DS_Store + +# /testsuite/tests/typing-misc/ +/testsuite/tests/typing-misc/*.o +/testsuite/tests/typing-misc/*.a +/testsuite/tests/typing-misc/*.so +/testsuite/tests/typing-misc/*.obj +/testsuite/tests/typing-misc/*.cm[ioxa] +/testsuite/tests/typing-misc/*.cmx[as] +/testsuite/tests/typing-misc/*.annot +/testsuite/tests/typing-misc/*.result +/testsuite/tests/typing-misc/*.byte +/testsuite/tests/typing-misc/*.native +/testsuite/tests/typing-misc/program +/testsuite/tests/typing-misc/.depend +/testsuite/tests/typing-misc/.depend.nt +/testsuite/tests/typing-misc/.DS_Store + +# /testsuite/tests/typing-modules/ +/testsuite/tests/typing-modules/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-modules/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-modules/_log +/testsuite/tests/typing-modules/*.so +/testsuite/tests/typing-modules/*.a +/testsuite/tests/typing-modules/*.result +/testsuite/tests/typing-modules/*.byte +/testsuite/tests/typing-modules/*.native +/testsuite/tests/typing-modules/program + +# /testsuite/tests/typing-modules-bugs/ +/testsuite/tests/typing-modules-bugs/*.o +/testsuite/tests/typing-modules-bugs/*.a +/testsuite/tests/typing-modules-bugs/*.so +/testsuite/tests/typing-modules-bugs/*.obj +/testsuite/tests/typing-modules-bugs/*.cm[ioxa] +/testsuite/tests/typing-modules-bugs/*.cmx[as] +/testsuite/tests/typing-modules-bugs/*.annot +/testsuite/tests/typing-modules-bugs/*.result +/testsuite/tests/typing-modules-bugs/*.byte +/testsuite/tests/typing-modules-bugs/*.native +/testsuite/tests/typing-modules-bugs/program +/testsuite/tests/typing-modules-bugs/program.exe +/testsuite/tests/typing-modules-bugs/.depend +/testsuite/tests/typing-modules-bugs/.depend.nt +/testsuite/tests/typing-modules-bugs/.DS_Store + +# /testsuite/tests/typing-objects/ +/testsuite/tests/typing-objects/*.o +/testsuite/tests/typing-objects/*.a +/testsuite/tests/typing-objects/*.so +/testsuite/tests/typing-objects/*.obj +/testsuite/tests/typing-objects/*.cm[ioxa] +/testsuite/tests/typing-objects/*.cmx[as] +/testsuite/tests/typing-objects/*.annot +/testsuite/tests/typing-objects/*.result +/testsuite/tests/typing-objects/*.byte +/testsuite/tests/typing-objects/*.native +/testsuite/tests/typing-objects/program +/testsuite/tests/typing-objects/.depend +/testsuite/tests/typing-objects/.depend.nt +/testsuite/tests/typing-objects/.DS_Store + +# /testsuite/tests/typing-objects-bugs/ +/testsuite/tests/typing-objects-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-objects-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-objects-bugs/_log +/testsuite/tests/typing-objects-bugs/*.so +/testsuite/tests/typing-objects-bugs/*.a +/testsuite/tests/typing-objects-bugs/*.result +/testsuite/tests/typing-objects-bugs/*.byte +/testsuite/tests/typing-objects-bugs/*.native +/testsuite/tests/typing-objects-bugs/program +/testsuite/tests/typing-objects-bugs/*.cm* +/testsuite/tests/typing-objects-bugs/*.o + +# /testsuite/tests/typing-poly/ +/testsuite/tests/typing-poly/*.o +/testsuite/tests/typing-poly/*.a +/testsuite/tests/typing-poly/*.so +/testsuite/tests/typing-poly/*.obj +/testsuite/tests/typing-poly/*.cm[ioxa] +/testsuite/tests/typing-poly/*.cmx[as] +/testsuite/tests/typing-poly/*.annot +/testsuite/tests/typing-poly/*.result +/testsuite/tests/typing-poly/*.byte +/testsuite/tests/typing-poly/*.native +/testsuite/tests/typing-poly/program +/testsuite/tests/typing-poly/.depend +/testsuite/tests/typing-poly/.depend.nt +/testsuite/tests/typing-poly/.DS_Store + +# /testsuite/tests/typing-poly-bugs/ +/testsuite/tests/typing-poly-bugs/*.o +/testsuite/tests/typing-poly-bugs/*.a +/testsuite/tests/typing-poly-bugs/*.so +/testsuite/tests/typing-poly-bugs/*.obj +/testsuite/tests/typing-poly-bugs/*.cm[ioxa] +/testsuite/tests/typing-poly-bugs/*.cmx[as] +/testsuite/tests/typing-poly-bugs/*.annot +/testsuite/tests/typing-poly-bugs/*.result +/testsuite/tests/typing-poly-bugs/*.byte +/testsuite/tests/typing-poly-bugs/*.native +/testsuite/tests/typing-poly-bugs/program +/testsuite/tests/typing-poly-bugs/program.exe +/testsuite/tests/typing-poly-bugs/.depend +/testsuite/tests/typing-poly-bugs/.depend.nt +/testsuite/tests/typing-poly-bugs/.DS_Store + +# /testsuite/tests/typing-polyvariants-bugs/ +/testsuite/tests/typing-polyvariants-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-polyvariants-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-polyvariants-bugs/_log +/testsuite/tests/typing-polyvariants-bugs/*.so +/testsuite/tests/typing-polyvariants-bugs/*.a +/testsuite/tests/typing-polyvariants-bugs/*.result +/testsuite/tests/typing-polyvariants-bugs/*.byte +/testsuite/tests/typing-polyvariants-bugs/*.native +/testsuite/tests/typing-polyvariants-bugs/program +/testsuite/tests/typing-polyvariants-bugs/*.cm* +/testsuite/tests/typing-polyvariants-bugs/*.o + +# /testsuite/tests/typing-polyvariants-bugs-2/ +/testsuite/tests/typing-polyvariants-bugs-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-polyvariants-bugs-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-polyvariants-bugs-2/_log +/testsuite/tests/typing-polyvariants-bugs-2/*.so +/testsuite/tests/typing-polyvariants-bugs-2/*.a +/testsuite/tests/typing-polyvariants-bugs-2/*.result +/testsuite/tests/typing-polyvariants-bugs-2/*.byte +/testsuite/tests/typing-polyvariants-bugs-2/*.native +/testsuite/tests/typing-polyvariants-bugs-2/program +/testsuite/tests/typing-polyvariants-bugs-2/*.cm* +/testsuite/tests/typing-polyvariants-bugs-2/*.o + +# /testsuite/tests/typing-private/ +/testsuite/tests/typing-private/*.o +/testsuite/tests/typing-private/*.a +/testsuite/tests/typing-private/*.so +/testsuite/tests/typing-private/*.obj +/testsuite/tests/typing-private/*.cm[ioxa] +/testsuite/tests/typing-private/*.cmx[as] +/testsuite/tests/typing-private/*.annot +/testsuite/tests/typing-private/*.result +/testsuite/tests/typing-private/*.byte +/testsuite/tests/typing-private/*.native +/testsuite/tests/typing-private/program +/testsuite/tests/typing-private/.depend +/testsuite/tests/typing-private/.depend.nt +/testsuite/tests/typing-private/.DS_Store + +# /testsuite/tests/typing-private-bugs/ +/testsuite/tests/typing-private-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-private-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-private-bugs/_log +/testsuite/tests/typing-private-bugs/*.so +/testsuite/tests/typing-private-bugs/*.a +/testsuite/tests/typing-private-bugs/*.result +/testsuite/tests/typing-private-bugs/*.byte +/testsuite/tests/typing-private-bugs/*.native +/testsuite/tests/typing-private-bugs/program +/testsuite/tests/typing-private-bugs/*.cm* +/testsuite/tests/typing-private-bugs/*.o + +# /testsuite/tests/typing-recmod/ +/testsuite/tests/typing-recmod/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-recmod/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-recmod/_log +/testsuite/tests/typing-recmod/*.so +/testsuite/tests/typing-recmod/*.a +/testsuite/tests/typing-recmod/*.result +/testsuite/tests/typing-recmod/*.byte +/testsuite/tests/typing-recmod/*.native +/testsuite/tests/typing-recmod/program +/testsuite/tests/typing-recmod/*.cm* +/testsuite/tests/typing-recmod/*.o + +# /testsuite/tests/typing-short-paths/ +/testsuite/tests/typing-short-paths/*.o +/testsuite/tests/typing-short-paths/*.a +/testsuite/tests/typing-short-paths/*.so +/testsuite/tests/typing-short-paths/*.obj +/testsuite/tests/typing-short-paths/*.cm[ioxat] +/testsuite/tests/typing-short-paths/*.cmx[as] +/testsuite/tests/typing-short-paths/*.cmti +/testsuite/tests/typing-short-paths/*.annot +/testsuite/tests/typing-short-paths/*.result +/testsuite/tests/typing-short-paths/*.byte +/testsuite/tests/typing-short-paths/*.native +/testsuite/tests/typing-short-paths/program +/testsuite/tests/typing-short-paths/program.exe +/testsuite/tests/typing-short-paths/.depend +/testsuite/tests/typing-short-paths/.depend.nt +/testsuite/tests/typing-short-paths/.DS_Store + +# /testsuite/tests/typing-signatures/ +/testsuite/tests/typing-signatures/*.o +/testsuite/tests/typing-signatures/*.a +/testsuite/tests/typing-signatures/*.so +/testsuite/tests/typing-signatures/*.obj +/testsuite/tests/typing-signatures/*.cm[ioxa] +/testsuite/tests/typing-signatures/*.cmx[as] +/testsuite/tests/typing-signatures/*.annot +/testsuite/tests/typing-signatures/*.result +/testsuite/tests/typing-signatures/*.byte +/testsuite/tests/typing-signatures/*.native +/testsuite/tests/typing-signatures/program +/testsuite/tests/typing-signatures/.depend +/testsuite/tests/typing-signatures/.depend.nt +/testsuite/tests/typing-signatures/.DS_Store + +# /testsuite/tests/typing-sigsubst/ +/testsuite/tests/typing-sigsubst/*.o +/testsuite/tests/typing-sigsubst/*.a +/testsuite/tests/typing-sigsubst/*.so +/testsuite/tests/typing-sigsubst/*.obj +/testsuite/tests/typing-sigsubst/*.cm[ioxa] +/testsuite/tests/typing-sigsubst/*.cmx[as] +/testsuite/tests/typing-sigsubst/*.annot +/testsuite/tests/typing-sigsubst/*.result +/testsuite/tests/typing-sigsubst/*.byte +/testsuite/tests/typing-sigsubst/*.native +/testsuite/tests/typing-sigsubst/program +/testsuite/tests/typing-sigsubst/.depend +/testsuite/tests/typing-sigsubst/.depend.nt +/testsuite/tests/typing-sigsubst/.DS_Store + +# /testsuite/tests/typing-typeparam/ +/testsuite/tests/typing-typeparam/*.o +/testsuite/tests/typing-typeparam/*.a +/testsuite/tests/typing-typeparam/*.so +/testsuite/tests/typing-typeparam/*.obj +/testsuite/tests/typing-typeparam/*.cm[ioxa] +/testsuite/tests/typing-typeparam/*.cmx[as] +/testsuite/tests/typing-typeparam/*.annot +/testsuite/tests/typing-typeparam/*.result +/testsuite/tests/typing-typeparam/*.byte +/testsuite/tests/typing-typeparam/*.native +/testsuite/tests/typing-typeparam/program +/testsuite/tests/typing-typeparam/.depend +/testsuite/tests/typing-typeparam/.depend.nt +/testsuite/tests/typing-typeparam/.DS_Store + +# /testsuite/tests/typing-warnings/ +/testsuite/tests/typing-warnings/*.o +/testsuite/tests/typing-warnings/*.a +/testsuite/tests/typing-warnings/*.so +/testsuite/tests/typing-warnings/*.obj +/testsuite/tests/typing-warnings/*.cm[ioxat] +/testsuite/tests/typing-warnings/*.cmx[as] +/testsuite/tests/typing-warnings/*.cmti +/testsuite/tests/typing-warnings/*.annot +/testsuite/tests/typing-warnings/*.result +/testsuite/tests/typing-warnings/*.byte +/testsuite/tests/typing-warnings/*.native +/testsuite/tests/typing-warnings/program +/testsuite/tests/typing-warnings/program.exe +/testsuite/tests/typing-warnings/.depend +/testsuite/tests/typing-warnings/.depend.nt +/testsuite/tests/typing-warnings/.DS_Store + +# /testsuite/tests/utils/ +/testsuite/tests/utils/*.o +/testsuite/tests/utils/*.a +/testsuite/tests/utils/*.so +/testsuite/tests/utils/*.obj +/testsuite/tests/utils/*.cm[ioxat] +/testsuite/tests/utils/*.cmx[as] +/testsuite/tests/utils/*.cmti +/testsuite/tests/utils/*.annot +/testsuite/tests/utils/*.result +/testsuite/tests/utils/*.byte +/testsuite/tests/utils/*.native +/testsuite/tests/utils/program +/testsuite/tests/utils/program.exe +/testsuite/tests/utils/.depend +/testsuite/tests/utils/.depend.nt +/testsuite/tests/utils/.DS_Store + +# /testsuite/tests/warnings/ +/testsuite/tests/warnings/*.o +/testsuite/tests/warnings/*.a +/testsuite/tests/warnings/*.so +/testsuite/tests/warnings/*.obj +/testsuite/tests/warnings/*.lib +/testsuite/tests/warnings/*.dll +/testsuite/tests/warnings/*.cm[ioxat] +/testsuite/tests/warnings/*.cmx[as] +/testsuite/tests/warnings/*.cmti +/testsuite/tests/warnings/*.annot +/testsuite/tests/warnings/*.result +/testsuite/tests/warnings/*.byte +/testsuite/tests/warnings/*.native +/testsuite/tests/warnings/program +/testsuite/tests/warnings/*.exe +/testsuite/tests/warnings/*.exe.manifest +/testsuite/tests/warnings/.depend +/testsuite/tests/warnings/.depend.nt +/testsuite/tests/warnings/.DS_Store + +# /tools/ +/tools/*.o +/tools/*.a +/tools/*.so +/tools/*.obj +/tools/*.lib +/tools/*.dll +/tools/*.cm[ioxat] +/tools/*.cmx[as] +/tools/*.cmti +/tools/*.annot +/tools/*.result +/tools/*.byte +/tools/*.native +/tools/program +/tools/*.exe +/tools/*.exe.manifest +/tools/.depend +/tools/.depend.nt +/tools/.DS_Store +/tools/ocamldep +/tools/ocamldep.opt +/tools/ocamldep.bak +/tools/ocamlprof +/tools/opnames.ml +/tools/dumpobj +/tools/dumpapprox +/tools/objinfo +/tools/cvt_emit +/tools/cvt_emit.bak +/tools/cvt_emit.ml +/tools/ocamlcp +/tools/ocamloptp +/tools/ocamlmktop +/tools/primreq +/tools/ocamldumpobj +/tools/keywords +/tools/lexer299.ml +/tools/ocaml299to3 +/tools/ocamlmklib +/tools/ocamlmklibconfig.ml +/tools/lexer301.ml +/tools/scrapelabels +/tools/addlabels +/tools/objinfo_helper +/tools/read_cmt +/tools/read_cmt.opt + +# /toplevel/ +/toplevel/.depend +/toplevel/configure +/toplevel/ocamlc +/toplevel/ocamlc.opt +/toplevel/expunge +/toplevel/ocaml +/toplevel/ocamlopt +/toplevel/ocamlopt.opt +/toplevel/ocamlcomp.sh +/toplevel/ocamlcompopt.sh +/toplevel/package-macosx +/toplevel/.DS_Store +/toplevel/*.annot +/toplevel/_boot_log1 +/toplevel/_boot_log2 +/toplevel/_build +/toplevel/_log +/toplevel/myocamlbuild_config.ml +/toplevel/ocamlnat +/toplevel/*.cm* +/toplevel/*.o + +# /typing/ +/typing/*.o +/typing/*.a +/typing/*.so +/typing/*.obj +/typing/*.dll +/typing/*.cm[ioxat] +/typing/*.cmx[as] +/typing/*.cmti +/typing/*.annot +/typing/*.result +/typing/*.byte +/typing/*.native +/typing/program +/typing/*.exe +/typing/.depend +/typing/.depend.nt +/typing/.DS_Store + +# /utils/ +/utils/*.o +/utils/*.a +/utils/*.so +/utils/*.obj +/utils/*.dll +/utils/*.cm[ioxat] +/utils/*.cmx[as] +/utils/*.cmti +/utils/*.annot +/utils/*.result +/utils/*.byte +/utils/*.native +/utils/program +/utils/*.exe +/utils/.depend +/utils/.depend.nt +/utils/.DS_Store +/utils/config.ml + +# /yacc/ +/yacc/*.o +/yacc/*.a +/yacc/*.so +/yacc/*.obj +/yacc/*.cm[ioxa] +/yacc/*.cmx[as] +/yacc/*.annot +/yacc/*.result +/yacc/*.byte +/yacc/*.native +/yacc/program +/yacc/program.exe +/yacc/.depend +/yacc/.depend.nt +/yacc/.DS_Store +/yacc/ocamlyacc +/yacc/ocamlyacc.exe +/yacc/version.h +/yacc/.gdb_history diff --git a/.ignore b/.ignore index 7e8d3f05..6dce10ee 100644 --- a/.ignore +++ b/.ignore @@ -8,12 +8,4 @@ ocamlopt.opt ocamlcomp.sh ocamlcompopt.sh package-macosx -_boot_log1 -_boot_log2 -_build -_start -_buildtest -_log -myocamlbuild_config.ml -ocamlbuild-mixed-boot ocamlnat diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 00000000..324a3827 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1,2 @@ +match_clause=4 +strict_with=auto diff --git a/.travis-ci.sh b/.travis-ci.sh new file mode 100644 index 00000000..788c997a --- /dev/null +++ b/.travis-ci.sh @@ -0,0 +1,18 @@ +case $XARCH in +i386) + ./configure + make world.opt + sudo make install + cd testsuite && make all + git clone git://github.com/ocaml/camlp4 + cd camlp4 && ./configure && make && sudo make install + git clone git://github.com/ocaml/opam + cd opam && ./configure && make lib-ext && make && sudo make install + opam init -y -a git://github.com/ocaml/opam-repository + opam install -y utop + ;; +*) + echo unknown arch + exit 1 + ;; +esac diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..3015c16d --- /dev/null +++ b/.travis.yml @@ -0,0 +1,4 @@ +language: c +script: bash -ex .travis-ci.sh +env: + - XARCH=i386 diff --git a/Changes b/Changes index 1056294a..55c3b9a8 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,356 @@ +OCaml 4.02.0: +------------- + +(Changes that can break existing programs are marked with a "*") + +Language features: +- Attributes and extension nodes + (Alain Frisch) +- Generative functors (PR#5905) + (Jacques Garrigue) +- Module aliases + (Jacques Garrigue) +* Alternative syntax for string literals {id|...|id} (can break comments) + (Alain Frisch) +- Separation between read-only strings (type string) and read-write byte + sequences (type bytes). Activated by command-line option -safe-string. + (Damien Doligez) +- PR#6318: Exception cases in pattern matching + (Jeremy Yallop, backend by Alain Frisch) +- PR#5584: Extensible open datatypes + (Leo White) + +Build system for the OCaml distribution: +- Use -bin-annot when building. +- Use GNU make instead of portable makefiles. +- Updated build instructions for 32-bit Mac OS X on Intel hardware. + +Shedding weight: +* Removed Camlp4 from the distribution, now available as third-party software. +* Removed Labltk from the distribution, now available as a third-party library. + +Type system: +* PR#6235: Keep typing of pattern cases independent in principal mode + (i.e. information from previous cases is no longer used when typing + patterns; cf. 'PR#6235' in testsuite/test/typing-warnings/records.ml) + (Jacques Garrigue) +- Allow opening a first-class module or applying a generative functor + in the body of a generative functor. Allow it also in the body of + an applicative functor if no types are created + (Jacques Garrigue, suggestion by Leo White) +* Module aliases are now typed in a specific way, which remembers their + identity. In particular this changes the signature inferred by + "module type of" + (Jacques Garrigue, feedback from Leo White, Mark Shinwell and Nick Chapman) +- PR#6331: Slight change in the criterion to distinguish private + abbreviations and private row types: create a private abbreviation for + closed objects and fixed polymorphic variants. + (Jacques Garrigue) +* PR#6333: Compare first class module types structurally rather than + nominally. Value subtyping allows module subtyping as long as the internal + representation is unchanged. + (Jacques Garrigue) + +Compilers: +- More aggressive constant propagation, including float and + int32/int64/nativeint arithmetic. Constant propagation for floats + can be turned off with option -no-float-const-prop, for codes that + change FP rounding modes at run-time. + (Xavier Leroy) +- New back-end optimization pass: common subexpression elimination (CSE). + (Reuses results of previous computations instead of recomputing them.) + (Xavier Leroy) +- New back-end optimization pass: dead code elimination. + (Removes arithmetic and load instructions whose results are unused.) + (Xavier Leroy) +- PR#6269: Optimization of sequences of string patterns + (Benoît Vaugon and Luc Maranget) +- Experimental native code generator for AArch64 (ARM 64 bits) + (Xavier Leroy) +- PR#6042: Optimization of integer division and modulus by constant divisors + (Xavier Leroy and Phil Denys) +- Add "-open" command line flag for opening a single module before typing + (Leo White, Mark Shinwell and Nick Chapman) +* "-o" now sets module name to the output file name up to the first "." + (it also applies when "-o" is not given, i.e. the module name is then + the input file name up to the first ".") + (Leo White, Mark Shinwell and Nick Chapman) +* PR#5779: better sharing of structured constants + (Alain Frisch) +- PR#5817: new flag to keep locations in cmi files + (Alain Frisch) +- PR#5854: issue warning 3 when referring to a value marked with + the [@@ocaml.deprecated] attribute + (Alain Frisch, suggestion by Pierre-Marie Pédrot) +- PR#6017: a new format implementation based on GADTs + (Benoît Vaugon and Gabriel Scherer) +* PR#6203: Constant exception constructors no longer allocate + (Alain Frisch) +- PR#6260: avoid unnecessary boxing in let + (Vladimir Brankov) +- PR#6345: Better compilation of optional arguments with default values + (Alain Frisch, review by Jacques Garrigue) +- PR#6389: ocamlopt -opaque option for incremental native compilation + (Pierre Chambart, Gabriel Scherer) + +Toplevel interactive system: +- PR#5377: New "#show_*" directives + (ygrek, Jacques Garrigue and Alain Frisch) + +Runtime system: +- New configure option "-no-naked-pointers" to improve performance by + avoiding page table tests during block darkening and the marking phase + of the major GC. In this mode, all out-of-heap pointers must point at + things that look like OCaml values: in particular they must have a valid + header. The colour of said headers should be black. + (Mark Shinwell, reviews by Damien Doligez and Xavier Leroy) +- Fixed bug in native code version of [caml_raise_with_string] that could + potentially lead to heap corruption. + (Mark Shinwell) +- Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with + [Val_unit] rather than zero. + (Mark Shinwell) +- Fixed a major performance problem on large heaps (~1GB) by making heap + increments proportional to heap size by default + (Damien Doligez) +- PR#4765: Structural equality treats exception specifically + (Alain Frisch) +- PR#5009: efficient comparison/indexing of exceptions + (Alain Frisch, request by Markus Mottl) +- PR#6075: avoid using unsafe C library functions (strcpy, strcat, sprintf) + (Xavier Leroy, reports from user 'jfc' and Anil Madhavapeddy) +- An ISO C99-compliant C compiler and standard library is now assumed. + (Plus special exceptions for MSVC.) In particular, emulation code for + 64-bit integer arithmetic was removed, the C compiler must support a + 64-bit integer type. + (Xavier Leroy) + +Standard library: +* Add new modules Bytes and BytesLabels for mutable byte sequences. + (Damien Doligez) +- PR#4986: add List.sort_uniq and Set.of_list + (Alain Frisch) +- PR#5935: a faster version of "raise" which does not maintain the backtrace + (Alain Frisch) +- PR#6146: support "Unix.kill pid Sys.sigkill" under Windows + (Romain Bardou and Alain Frisch) +- PR#6148: speed improvement for Buffer + (John Whitington) +- PR#6180: efficient creation of uninitialized float arrays + (Alain Frisch, request by Markus Mottl) +- PR#6355: Improve documentation regarding finalisers and multithreading + (Daniel Bünzli, Mark Shinwell) +- Trigger warning 3 for all values marked as deprecated in the documentation. + (Damien Doligez) + +OCamldoc: +- PR#6257: handle full doc comments for variant constructors and + record fields + (Maxence Guesdon, request by ygrek) +- PR#6274: allow doc comments on object types + (Thomas Refis) +- PR#6310: fix ocamldoc's subscript/superscript CSS font size + (Anil Madhavapeddy) +- PR#6425: fix generation of man pages + (Maxence Guesdon, report by Anil Madhavapeddy) + +Bug fixes: +- PR#2719: wrong scheduling of bound checks within a + try...with Invalid_argument -> _ ... (Xavier Leroy) +- PR#4719: Sys.executable_name wrong if executable name contains dots (Windows) + (Alain Frisch, report by Bart Jacobs) +- PR#5406 ocamlbuild: "tag 'package' does not expect a parameter" + (Gabriel Scherer) +- PR#5598, PR#6165: Alterations to handling of \013 in source files + breaking other tools + (David Allsopp and Damien Doligez) +- PR#5820: Fix camlp4 lexer roll back problem + (Hongbo Zhang) +- PR#5946: CAMLprim taking (void) as argument + (Benoît Vaugon) +- PR#6038: on x86-32, enforce 16-byte stack alignment for compatibility + with recent GCC and Clang. Win32/MSVC keeps 4-byte stack alignment. + (Xavier Leroy) +- PR#6062: Fix a 4.01 camlp4 DELETE_RULE regression caused by commit 13047 + (Hongbo Zhang, report by Christophe Troestler) +- PR#6173: Typing error message is worse than before + (Jacques Garrigue and John Whitington) +- PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case) + (Jacques Garrigue and Grégoire Henry, report by Chantal Keller) +- PR#6175: open! was not suppored by camlp4 + (Hongbo Zhang) +- PR#6184: ocamlbuild: `ocamlfind ocamldep` does not support -predicate + (Jacques-Pascal Deplaix) +- PR#6194: Incorrect unused warning with first-class modules in patterns + (Jacques Garrigue, report by Markus Mottl and Leo White) +- PR#6211: in toplevel interactive use, bad interaction between uncaught + exceptions and multiple bindings of the form "let x = a let y = b;;". + (Xavier Leroy) +- PR#6216: inlining of GADT matches generates invalid assembly + (Xavier Leroy and Alain Frisch, report by Mark Shinwell) +- PR#6232: Don't use [mktemp] on platforms where [mkstemp] is available + (Stéphane Glondu, Mark Shinwell) +- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC + (Jacques-Henri Jourdan and Xavier Leroy, + report and testing by Stéphane Glondu) +- PR#6235: Issue with type information flowing through a variant pattern + (Jacques Garrigue, report by Hongbo Zhang) +- PR#6239: sometimes wrong stack alignment when raising exceptions + in -g mode with backtraces active + (Xavier Leroy, report by Yaron Minsky) +- PR#6240: Fail to expand module type abbreviation during substyping + (Jacques Garrigue, report by Leo White) +- PR#6241: Assumed inequality between paths involving functor arguments + (Jacques Garrigue, report by Jeremy Yallop) +- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations + (Xavier Leroy, report by Pierre-Marie Pédrot) +- PR#6262: equality of first-class modules take module aliases into account + (Alain Frisch and Leo White) +- PR#6268: -DMODEL_$(MODEL) not passed when building asmrun/arm.p.o + (Peter Michael Green) +- PR#6273: fix Sys.file_exists on large files (Win32) + (Christoph Bauer) +- PR#6275: Soundness bug related to type constraints + (Jacques Garrigue, report by Leo White) +- PR#6293: Assert_failure with invalid package type + (Jacques Garrigue, report by Elnatan Reisner) +- PR#6300: ocamlbuild -use-ocamlfind conflicts with -ocamlc + (Gabriel Scherer) +- PR#6302: bytecode debug information re-read from filesystem every time + (Jacques-Henri Jourdan) +- PR#6307: Behavior of 'module type of' w.r.t. module aliases + (Jacques Garrigue, report by Alain Frisch) +- PR#6332: Unix.open_process fails to pass empty arguments under Windows + (Damien Doligez, report Virgile Prevosto) +- PR#6346: Build failure with latest version of xcode on OSX + (Jérémie Dimino) +- PR#6348: Unification failure for GADT when original definition is hidden + (Leo White and Jacques Garrigue, report by Jeremy Yallop) +- PR#6352: Automatic removal of optional arguments and sequencing + (Jacques Garrigue and Alain Frisch) +- PR#6361: Hashtbl.hash not terminating on some lazy values w/ recursive types + (Xavier Leroy, report by Leo White) +- PR#6383: Exception Not_found when using object type in absent module + (Jacques Garrigue, report by Sébastien Briais) +- PR#6384: Uncaught Not_found exception with a hidden .cmi file + (Leo White) +- PR#6385: wrong allocation of large closures by the bytecode interpreter + (Xavier Leroy, report by Stephen Dolan) +- PR#6394: Assertion failed in Typecore.expand_path + (Alain Frisch and Jacques Garrigue) +- PR#6405: unsound interaction of -rectypes and GADTs + (Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon) +- PR#6408: Optional arguments given as ~?arg instead of ?arg in message + (Michael O'Connor) +- PR#6411: missing libgcc_s_sjlj-1.dll in mingw (add -static-libgcc) + (Jun Furuse and Alain Frisch, Jonathan Protzenko and Adrien Nader) +- PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli + (John Whitington) +- PR#6439: Don't use the deprecated [getpagesize] function + (John Whitington, Mark Shinwell) +- PR#6441: undetected tail-call in some mutually-recursive functions + (many arguments, and mutual block mixes functions and non-functions) + (Stefan Holdermans, review by Xavier Leroy) +- PR#6443: ocaml segfault when List.fold_left is traced then executed + (Jacques Garrigue, report by user 'Reventlov') +- PR#6451: some bugs in untypeast.ml + (Jun Furuse, review by Alain Frisch) +- PR#6460: runtime assertion failure with large [| e1;...eN |] + float array expressions + (Leo White) +- PR#6463: -dtypedtree fails on class fields + (Leo White) +- PR#6469: invalid -dsource printing of "external _pipe = ...", "Pervasives.(!)" + (Gabriel Scherer and Damien Doligez, user 'ngunn') +- PR#6482: ocamlbuild fails when _tags file in unhygienic directory + (Gabriel Scherer) +- PR#6502: ocamlbuild spurious warning on "use_menhir" tag + (Xavier Leroy) +- PR#6505: Missed Type-error leads to a segfault upon record access + (Jacques Garrigue, Jeremy Yallop, report by Christoph Höger) +- PR#6507: crash on AArch64 resulting from incorrect setting of + [caml_bottom_of_stack]. (Richard Jones, Mark Shinwell) +- PR#6509: add -linkall flag to ocamlcommon.cma + (Frédéric Bour) +- PR#6513: Fatal error Ctype.Unify(_) in functor type +- PR#6523: failure upon character bigarray access, and unnecessary change + in comparison ordering (Jeremy Yallop, Mark Shinwell) +- bound-checking bug in caml_string_{get,set}{16,32,64} + (Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez) +- sometimes wrong stack alignment at out-of-bounds array access + (Gabriel Scherer and Xavier Leroy, report by Pierre Chambart) + +Features wishes: +- PR#4243: make the Makefiles parallelizable + (Grégoire Henry and Damien Doligez) +- PR#4323: have "of_string" in Num and Big_int work with binary and + hex representations + (Zoe Paraskevopoulou, review by Gabriel Scherer) +- PR#4771: Clarify documentation of Dynlink.allow_only + (Damien Doligez, report by David Allsopp) +- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' + (Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk) +- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances + (user 'daweil') +- PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types + (Hongbo Zhang) +- PR#5808: allow simple patterns, not just identifiers, in "let p : t = ..." + (Alain Frisch) +- PR#5851: warn when -r is disabled because no _tags file is present + (Gabriel Scherer) +- PR#5899: a programmer-friendly access to backtrace information + (Jacques-Henri Jourdan and Gabriel Scherer) +- PR#6000 comment 9644: add a warning for non-principal coercions to format + (Jacques Garrigue, report by Damien Doligez) +- PR#6054: add support for M.[ foo ], M.[| foo |] etc. + (Kaustuv Chaudhuri) +- PR#6064: GADT representation for Bigarray.kind + CAML_BA_CHAR runtime kind + (Jeremy Yallop, review by Gabriel Scherer) +- PR#6071: Add a -noinit option to the toplevel + (David Sheets) +- PR#6087: ocamlbuild, improve _tags parsing of escaped newlines + (Gabriel Scherer, request by Daniel Bünzli) +- PR#6109: Typos in ocamlbuild error messages + (Gabriel Kerneis) +- PR#6116: more efficient implementation of Digest.to_hex + (ygrek) +- PR#6142: add cmt file support to ocamlobjinfo + (Anil Madhavapeddy) +- PR#6166: document -ocamldoc option of ocamlbuild + (Xavier Clerc) +- PR#6182: better message for virtual objects and class types + (Leo White, Stephen Dolan) +- PR#6183: enhanced documentation for 'Unix.shutdown_connection' + (Anil Madhavapeddy, report by Jun Furuse) +- PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml + (Jacques-Pascal Deplaix) +- PR#6246: allow wildcard _ as for-loop index + (Alain Frisch, request by ygrek) +- PR#6267: more information printed by "bt" command of ocamldebug + (Josh Watzman) +- PR#6270: remove need for -I directives to ocamldebug in common case + (Josh Watzman, review by Xavier Clerc and Alain Frisch) +- PR#6311: Improve signature mismatch error messages + (Alain Frisch, suggestion by Daniel Bünzli) +- PR#6358: obey DESTDIR in install targets + (Gabriel Scherer, request by François Berenger) +- PR#6388, PR#6424: more parsetree correctness checks for -ppx users + (Alain Frisch, request by Peter Zotov and Jun Furuse) +- PR#6406: Expose OCaml version in C headers + (Peter Zotov and Romain Calascibetta) +- PR#6446: improve "unused declaration" warnings wrt. name shadowing + (Alain Frisch) +- PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string' + (Anil Madhavapeddy) +- PR#6497: pass context information to -ppx preprocessors + (Peter Zotov, Alain Frisch) +- ocamllex: user-definable refill action + (Frédéric Bour, review by Gabriel Scherer and Luc Maranget) +- shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .." + (Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer) +- make ocamldebug -I auto-detection work with ocamlbuild + (Josh Watzman) + OCaml 4.01.0: ------------- @@ -69,6 +422,9 @@ Standard library: (Xavier Leroy) - infix application operators |> and @@ in Pervasives (Fabrice Le Fessant) +- PR#6176: new Format.asprintf function with a %a formatter + compatible with Format.fprintf (unlike Format.sprintf) + (Pierre Weis) Other libraries: - PR#5568: add O_CLOEXEC flag to Unix.openfile, so that the returned @@ -150,7 +506,7 @@ Bug fixes: (Alain Frisch) - PR#5552: unrecognized gcc option -no-cpp-precomp (Damien Doligez, report by Markus Mottl) -- PR#5580: missed opportunities for constant propagation +* PR#5580: missed opportunities for constant propagation (Xavier Leroy and John Carr) - PR#5611: avoid clashes betwen .cmo files and output files during linking (Wojciech Meyer) @@ -347,8 +703,6 @@ Bug fixes: (Jacques Garrigue, report by Elnatan Reisner) - PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails (Gabriel Scherer, report by Hezekiah M. Carty) -- PR#6060: ocamlbuild rules for -principal, -strict-sequence and -short-paths - (Anil Madhavapeddy) - PR#6069: ocamldoc: lexing: empty token (Maxence Guesdon, Grégoire Henry, report by ygrek) - PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly @@ -370,6 +724,8 @@ Bug fixes: (Jacques Garrigue, report by Leo P. White) - PR#6164: segmentation fault on Num.power_num of 0/1 (Fabrice Le Fessant, report by Johannes Kanig) +- PR#6210: Camlp4 location error + (Hongbo Zhang, report by Jun Furuse) Feature wishes: - PR#5181: Merge common floating point constants in ocamlopt @@ -412,6 +768,10 @@ Feature wishes: (Anil Madhavapeddy, review by Benedikt Meurer) - PR#6059: add -output-obj rules for ocamlbuild (Anil Madhavapeddy) +- PR#6060: ocamlbuild tags 'principal', 'strict_sequence' and 'short_paths' + (Anil Madhavapeddy) +- ocamlbuild tag 'no_alias_deps' + (Daniel Bünzli) Tools: - OCamlbuild now features a bin_annot tag to generate .cmt files. @@ -563,6 +923,7 @@ Installation procedure: (-runtime-variant) to select the debug runtime. Bug Fixes: + - PR#1643: functions of the Lazy module whose named started with 'lazy_' have been deprecated, and new ones without the prefix added - PR#3571: in Bigarrays, call msync() before unmapping to commit changes diff --git a/INSTALL b/INSTALL index 813f2bf8..63ae5c67 100644 --- a/INSTALL +++ b/INSTALL @@ -15,11 +15,11 @@ PREREQUISITES are all *required*. The vendor-provided compiler, assembler and make have major problems. -* GNU make is needed to build ocamlbuild and camlp4. If your system's - default make is not GNU make, you need to define the GNUMAKE environment +* GNU make is needed to build ocamlbuild. If your system's default + make is not GNU make, you need to define the GNUMAKE environment variable to the name of GNU make, typically with this command: - export GNUMAKE=gnumake + export GNUMAKE=gmake INSTALLATION INSTRUCTIONS @@ -65,29 +65,20 @@ The "configure" script accepts the following options: hand. The installation instructions for gcc or emacs contain a complete list of configuration names. +-target (default: same as -host) + The type of the target machine, in GNU's "configuration name" + format (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM). + Setting this will setup OCaml as a cross-compiler which runs on + $host and produces code for $target. This requires a C toolchain + which also produces code for $target and a native OCaml + compiler of the exact same version (if you want a cross 4.00.1, + you need a native 4.00.1). + -x11include (default: determined automatically) -x11lib (default: determined automatically) Location of the X11 include directory (e.g. /usr/X11R6/include) and the X11 library directory (e.g. /usr/X11R6/lib). --tkdefs (default: none) --tklibs (default: determined automatically) - These options specify where to find the Tcl/Tk libraries for - LablTk. "-tkdefs" helps to find the headers, and "-tklibs" - the C libraries. "-tklibs" may contain either only -L/path and - -Wl,... flags, in which case the library names are determined - automatically, or the actual libraries, which are used as given. - Example: for a Japanese tcl/tk whose headers are in specific - directories and libraries in /usr/local/lib, you can use - ./configure -tklibs "-L/usr/local/lib -ltk8.0jp -ltcl8.0jp" - -tkdefs "-I/usr/local/include/tcl8.0jp -I/usr/local/include/tk8.0jp" - --tk-no-x11 - Build LablTk without using X11. This option is needed on Cygwin. - --no-tk - Do not attempt to build LablTk. - -no-pthread Do not attempt to use POSIX threads. @@ -120,8 +111,14 @@ The "configure" script accepts the following options: Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. --no-camlp4 - Do not compile Camlp4. +-no-debugger + Do not build ocamldebug. + +-no-ocamldoc + Do not build ocamldoc. + +-no-ocamlbuild + Do not build ocamlbuild. -no-graph Do not compile the Graphics library. @@ -156,8 +153,9 @@ Examples: to build a 64-bit version of OCaml: ./configure -cc "gcc -m64" - On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml: - ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c" + On Intel Mac OS X, to build a 32-bit version of OCaml: + ./configure -host "i386-apple-darwin13.2.0" -cc "gcc -arch i386 -m32" \ + -as "as -arch i386" -aspp "gcc -arch i386 -m32 -c" For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" @@ -320,6 +318,9 @@ Fix: do not pass the -j option to make, and be patient. * The Makefiles use the "include" directive, which is not supported by all versions of make. Use GNU make if this is a problem. +* Solaris make mishandles a space in our Makefiles, so you have to use GNU +make to build on Solaris. + * The Makefiles assume that make executes commands by calling /bin/sh. They won't work if /bin/csh is called instead. You may have to unset the SHELL environment variable, or set it to /bin/sh. diff --git a/LICENSE b/LICENSE index 29b5c850..8209011f 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ In the following, "the Library" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: - asmrun, byterun, camlp4, config, otherlibs, stdlib, win32caml + asmrun, byterun, config, otherlibs, stdlib, win32caml and "the Compiler" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: diff --git a/Makefile b/Makefile index 10c80d2f..733ed99d 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,8 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -w +33..39 -warn-error A $(INCLUDES) +COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \ + -safe-string $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -29,8 +30,10 @@ CAMLRUN=byterun/ocamlrun SHELL=/bin/sh MKDIR=mkdir -p -CAMLP4OUT=$(CAMLP4:=out) -CAMLP4OPT=$(CAMLP4:=opt) +OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte) +OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native) + +OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt) INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel @@ -40,6 +43,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ + parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ @@ -53,8 +57,8 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ - typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -79,12 +83,15 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ + asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ + asmcomp/comballoc.cmo \ + asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ + asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ + asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ @@ -116,8 +123,12 @@ defaultentry: @echo "should work. But see the file INSTALL for more details." # Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc +all: + $(MAKE) runtime + $(MAKE) coreall + $(MAKE) ocaml + $(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \ + $(WITH_OCAMLDOC) # Compile everything the first time world: @@ -134,11 +145,10 @@ world.opt: # # make coreboot [old system -- you were in a stable state] # -# make core [cross-compiler] -# make partialclean [if you get "inconsistent assumptions"] +# make clean runtime coreall # -# make core [cross-compiler] -# make coreboot [new system -- now you are in a stable state] +# make clean runtime coreall +# make coreboot [new system -- now in a stable state] # Core bootstrapping cycle coreboot: @@ -185,10 +195,14 @@ coldstart: ln -s ../byterun stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap -core: coldstart ocamlc ocamllex ocamlyacc ocamltools library +core: + $(MAKE) coldstart + $(MAKE) coreall # Recompile the core system using the bootstrap compiler -coreall: ocamlc ocamllex ocamlyacc ocamltools library +coreall: + $(MAKE) ocamlc + $(MAKE) ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -245,86 +259,112 @@ opt: $(MAKE) runtimeopt $(MAKE) ocamlopt $(MAKE) libraryopt - $(MAKE) otherlibrariesopt - $(MAKE) ocamltoolsopt - $(MAKE) ocamlbuildlib.native + $(MAKE) otherlibrariesopt ocamltoolsopt $(OCAMLBUILDNATIVE) # Native-code versions of the tools -opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \ - ocamlopt.opt otherlibrariesopt ocamllex.opt \ - ocamltoolsopt ocamltoolsopt.opt ocamldoc.opt ocamlbuild.native \ - $(CAMLP4OPT) +opt.opt: + $(MAKE) checkstack + $(MAKE) runtime + $(MAKE) core + $(MAKE) ocaml + $(MAKE) opt-core + $(MAKE) ocamlc.opt + $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) \ + $(OCAMLBUILDBYTE) + $(MAKE) ocamlopt.opt + $(MAKE) otherlibrariesopt + $(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT) \ + $(OCAMLBUILDNATIVE) -base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \ - otherlibrariesopt +base.opt: + $(MAKE) checkstack + $(MAKE) runtime + $(MAKE) core + $(MAKE) ocaml + $(MAKE) opt-core + $(MAKE) ocamlc.opt + $(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \ + $(WITH_OCAMLDOC) + $(MAKE) ocamlopt.opt + $(MAKE) otherlibrariesopt # Installation COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: - if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi - if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi - if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi - if test -d $(COMPLIBDIR); then : ; else $(MKDIR) $(COMPLIBDIR); fi - if test -d $(MANDIR)/man$(MANEXT); then : ; \ - else $(MKDIR) $(MANDIR)/man$(MANEXT); fi - cp VERSION $(LIBDIR)/ - cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ - dllthreads.so dllunix.so dllgraphics.so dllstr.so \ - dlltkanim.so + if test -d $(INSTALL_BINDIR); then : ; \ + else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_STUBLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_STUBLIBDIR); fi + if test -d $(INSTALL_COMPLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_COMPLIBDIR); fi + if test -d $(INSTALL_MANDIR)/man$(MANEXT); then : ; \ + else $(MKDIR) $(INSTALL_MANDIR)/man$(MANEXT); fi + cp VERSION $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); rm -f dllbigarray.so dllnums.so dllthreads.so \ + dllunix.so dllgraphics.so dllstr.so cd byterun; $(MAKE) install - cp ocamlc $(BINDIR)/ocamlc$(EXE) - cp ocaml $(BINDIR)/ocaml$(EXE) + cp ocamlc $(INSTALL_BINDIR)/ocamlc$(EXE) + cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install - cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) - cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex$(EXE) + cp yacc/ocamlyacc$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE) cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge$(EXE) - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge$(EXE) + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ done - cd ocamldoc; $(MAKE) install - if test -f ocamlopt; then $(MAKE) installopt; else :; fi - if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ + if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) install); else :; fi + if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKE) install); \ + else :; fi + if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - cp config/Makefile $(LIBDIR)/Makefile.config - BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) PREFIX=$(PREFIX) \ - ./build/partial-install.sh + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config + if test -f ocamlopt; then $(MAKE) installopt; else :; fi # Installation of the native-code compiler installopt: cd asmrun; $(MAKE) install - cp ocamlopt $(BINDIR)/ocamlopt$(EXE) + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt - cp asmcomp/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) - cd ocamldoc; $(MAKE) installopt + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) + if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \ + else :; fi + if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ + else :; fi for i in $(OTHERLIBRARIES); \ do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done if test -f ocamlopt.opt ; then $(MAKE) installoptopt; fi cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ - $(COMPLIBDIR) - cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ + $(INSTALL_COMPLIBDIR) + cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ ocamloptcomp.a clean:: partialclean @@ -332,7 +372,7 @@ clean:: partialclean # Shared parts of the system compilerlibs/ocamlcommon.cma: $(COMMON) - $(CAMLC) -a -o $@ $(COMMON) + $(CAMLC) -a -linkall -o $@ $(COMMON) partialclean:: rm -f compilerlibs/ocamlcommon.cma @@ -346,9 +386,6 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh # The native-code compiler @@ -360,12 +397,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -425,8 +459,9 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ + -e 's|%%HOST%%|$(HOST)|' \ + -e 's|%%TARGET%%|$(TARGET)|' \ utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml @@ -456,7 +491,7 @@ beforedepend:: parsing/lexer.ml # Shared parts of the system compiled with the native-code compiler compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) - $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) + $(CAMLOPT) -a -linkall -o $@ $(COMMON:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a @@ -472,9 +507,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -491,9 +523,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -556,6 +585,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + ln -s $(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml ln -s $(ARCH)/reload.ml asmcomp/reload.ml @@ -666,13 +703,15 @@ clean:: # Tools -ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools; $(MAKE) all ocamltoolsopt: ocamlopt cd tools; $(MAKE) opt -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools; $(MAKE) opt.opt partialclean:: @@ -689,6 +728,12 @@ ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex cd ocamldoc && $(MAKE) opt.opt +# Documentation + +html_doc: ocamldoc + make -C ocamldoc html_doc + @echo "documentation is in ./ocamldoc/stdlib_html/" + partialclean:: cd ocamldoc && $(MAKE) clean @@ -709,11 +754,11 @@ otherlibrariesopt: partialclean:: for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) partialclean); \ + (cd otherlibs/$$i && $(MAKE) partialclean); \ done clean:: - for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done + for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i && $(MAKE) clean); done alldepend:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done @@ -729,39 +774,25 @@ partialclean:: alldepend:: cd debugger; $(MAKE) depend -# Camlp4 - -camlp4out: ocamlc ocamlbuild.byte - ./build/camlp4-byte-only.sh - -camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native - ./build/camlp4-native-only.sh - # Ocamlbuild -#ifeq ($(OCAMLBUILD_NOBOOT),"yes") -#ocamlbuild.byte: ocamlc -# $(MAKE) -C ocamlbuild -f Makefile.noboot -#else -ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot - ./build/ocamlbuild-byte-only.sh -#endif -ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt - ./build/ocamlbuild-native-only.sh -ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot otherlibrariesopt - ./build/ocamlbuildlib-native-only.sh +ocamlbuild.byte: ocamlc otherlibraries + cd ocamlbuild && $(MAKE) all -ocamlbuild-mixed-boot: ocamlc - ./build/mixed-boot.sh - touch ocamlbuild-mixed-boot +ocamlbuild.native: ocamlopt otherlibrariesopt + cd ocamlbuild && $(MAKE) allopt partialclean:: - rm -rf _build ocamlbuild-mixed-boot + cd ocamlbuild && $(MAKE) clean + +alldepend:: + cd ocamlbuild && $(MAKE) depend # Check that the stack limit is reasonable. checkstack: - @if $(BYTECC) -o tools/checkstack tools/checkstack.c; \ + @if $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ + -o tools/checkstack tools/checkstack.c; \ then tools/checkstack; \ else :; \ fi @@ -798,7 +829,7 @@ clean:: partialclean:: for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ - do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done + do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend @@ -809,10 +840,15 @@ depend: beforedepend alldepend:: depend distclean: - ./build/distclean.sh - rm -f ocaml ocamlcomp.sh testsuite/_log - -.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean + $(MAKE) clean + rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \ + boot/*.cm* boot/libcamlrun.a + rm -f config/Makefile config/m.h config/s.h + rm -f tools/*.bak + rm -f ocaml ocamlc + rm -f testsuite/_log + +.PHONY: all backup bootstrap checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart .PHONY: compare core coreall .PHONY: coreboot defaultentry depend distclean install installopt diff --git a/Makefile.nt b/Makefile.nt index 41d9c4a8..648c918d 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -17,7 +17,7 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES) +COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc YACCFLAGS= @@ -26,8 +26,10 @@ CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun -CAMLP4OUT=$(CAMLP4:=out) -CAMLP4OPT=$(CAMLP4:=opt) +OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte) +OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native) + +OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt) INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel @@ -37,6 +39,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ + parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ @@ -50,8 +53,8 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ - typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -76,12 +79,15 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ - asmcomp/closure.cmo asmcomp/cmmgen.cmo \ + asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ + asmcomp/comballoc.cmo \ + asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ + asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ + asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ @@ -105,7 +111,8 @@ defaultentry: # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) + otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \ + $(WITH_OCAMLDOC) # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -113,12 +120,13 @@ all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ # Compile everything the first time world: coldstart all -# Complete bootstrapping cycle -bootstrap: +# Core bootstrapping cycle +coreboot: # Save the original bootstrap compiler $(MAKEREC) backup # Promote the new compiler but keep the old runtime -# This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun +# This compiler runs on boot/ocamlrun and produces bytecode for +# byterun/ocamlrun $(MAKEREC) promote-cross # Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) $(MAKEREC) partialclean @@ -127,12 +135,18 @@ bootstrap: $(MAKEREC) library-cross # Promote the new compiler and the new runtime $(MAKEREC) promote -# Rebuild everything, including ocaml and the tools +# Rebuild the core system $(MAKEREC) partialclean - $(MAKEREC) all + $(MAKEREC) core # Check if fixpoint reached $(MAKEREC) compare +# Do a complete bootstrapping cycle +bootstrap: + $(MAKEREC) coreboot + $(MAKEREC) all + $(MAKEREC) compare + LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler @@ -145,7 +159,7 @@ coldstart: cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap -core : runtime ocamlc ocamllex ocamlyacc ocamltools library +core: runtime ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -190,12 +204,18 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt-core: runtimeopt ocamlopt libraryopt -opt: opt-core otherlibrariesopt ocamlbuildlib.native +opt-core: + $(MAKE) -f Makefile.nt runtimeopt + $(MAKE) -f Makefile.nt ocamlopt + $(MAKE) -f Makefile.nt libraryopt + +opt: + $(MAKE) -f Makefile.nt opt-core + $(MAKE) -f Makefile.nt otherlibrariesopt ocamltoolsopt # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt.opt ocamlbuild.native $(CAMLP4OPT) ocamldoc.opt + ocamltoolsopt ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) # Complete build using fast compilers world.opt: coldstart opt.opt @@ -204,59 +224,71 @@ world.opt: coldstart opt.opt COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: installbyt installopt installbyt: - mkdir -p $(BINDIR) - mkdir -p $(LIBDIR) - mkdir -p $(COMPLIBDIR) + mkdir -p $(INSTALL_BINDIR) + mkdir -p $(INSTALL_LIBDIR) + mkdir -p $(INSTALL_STUBLIBDIR) + mkdir -p $(INSTALL_COMPLIBDIR) + cp VERSION $(INSTALL_LIBDIR)/ cd byterun ; $(MAKEREC) install - cp ocamlc $(BINDIR)/ocamlc.exe - cp ocaml $(BINDIR)/ocaml.exe + cp ocamlc $(INSTALL_BINDIR)/ocamlc.exe + cp ocaml $(INSTALL_BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install - cp lex/ocamllex $(BINDIR)/ocamllex.exe - cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex.exe + cp yacc/ocamlyacc.exe $(INSTALL_BINDIR)/ocamlyacc.exe cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge.exe - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge.exe + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools ; $(MAKEREC) install - cd ocamldoc ; $(MAKEREC) install - mkdir -p $(STUBLIBDIR) for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done - if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \ + if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \ + else :; fi + if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \ + else :; fi + if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - ./build/partial-install.sh - cp config/Makefile $(LIBDIR)/Makefile.config - cp README $(DISTRIB)/Readme.general.txt - cp README.win32 $(DISTRIB)/Readme.windows.txt - cp LICENSE $(DISTRIB)/License.txt - cp Changes $(DISTRIB)/Changes.txt + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config + cp README $(INSTALL_DISTRIB)/Readme.general.txt + cp README.win32 $(INSTALL_DISTRIB)/Readme.windows.txt + cp LICENSE $(INSTALL_DISTRIB)/License.txt + cp Changes $(INSTALL_DISTRIB)/Changes.txt # Installation of the native-code compiler installopt: cd asmrun ; $(MAKEREC) install - cp ocamlopt $(BINDIR)/ocamlopt.exe + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt - cp asmcomp/*.cmi driver/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) - cd ocamldoc ; $(MAKEREC) installopt + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) + if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) installopt); fi + if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ + else :; fi for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi + cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \ - $(COMPLIBDIR) + $(INSTALL_COMPLIBDIR) clean:: partialclean @@ -277,12 +309,9 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc compilerlibs/ocamlcommon.cma \ compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: - rm -f ocamlc ocamlcomp.sh + rm -f ocamlc # The native-code compiler @@ -294,12 +323,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -328,7 +354,7 @@ ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml - cd otherlibs/dynlink && $(MAKE) allopt + cd otherlibs/dynlink && $(MAKE) -f Makefile.nt allopt # The configuration file @@ -363,8 +389,9 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ -e 's|%%CC_PROFILE%%||' \ + -e 's|%%HOST%%|$(HOST)|' \ + -e 's|%%TARGET%%|$(TARGET)|' \ utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml @@ -410,9 +437,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -429,9 +453,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -500,6 +521,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + cp asmcomp/$(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml @@ -598,10 +627,17 @@ clean:: # Tools -ocamltools: asmcomp/cmx_format.cmi +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools ; $(MAKEREC) all -ocamltoolsopt.opt: asmcomp/cmx_format.cmi + +ocamltoolsopt: + cd tools ; $(MAKEREC) opt + +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools ; $(MAKEREC) opt.opt + partialclean:: cd tools ; $(MAKEREC) clean alldepend:: @@ -609,7 +645,7 @@ alldepend:: # OCamldoc -ocamldoc.byte: +ocamldoc: cd ocamldoc ; $(MAKEREC) all ocamldoc.opt: cd ocamldoc ; $(MAKEREC) opt.opt @@ -640,28 +676,19 @@ partialclean:: alldepend:: cd debugger; $(MAKEREC) depend -# Camlp4 - -camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte - ./build/camlp4-byte-only.sh -camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native - ./build/camlp4-native-only.sh - # Ocamlbuild -ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot - ./build/ocamlbuild-byte-only.sh -ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot - ./build/ocamlbuild-native-only.sh -ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot - ./build/ocamlbuildlib-native-only.sh +ocamlbuild.byte: ocamlc otherlibraries + cd ocamlbuild && $(MAKE) all +ocamlbuild.native: ocamlopt otherlibrariesopt + cd ocamlbuild && $(MAKE) allopt -.PHONY: ocamlbuild-mixed-boot -ocamlbuild-mixed-boot: - ./build/mixed-boot.sh partialclean:: - rm -rf _build + cd ocamlbuild && $(MAKE) clean + +alldepend:: + cd ocamlbuild && $(MAKE) depend # Make clean in the test suite @@ -699,16 +726,22 @@ depend: beforedepend alldepend:: depend distclean: - ./build/distclean.sh - -.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean + $(MAKE) clean + rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \ + boot/*.cm* boot/libcamlrun.a + rm -f config/Makefile config/m.h config/s.h + rm -f tools/*.bak + rm -f ocaml ocamlc + rm -f testsuite/_log + +.PHONY: all backup bootstrap checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart .PHONY: compare core coreall .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc -.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt -.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt +.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt diff --git a/README b/README index 06591e23..093ad8ed 100644 --- a/README +++ b/README @@ -54,7 +54,6 @@ CONTENTS: boot/ bootstrap compiler bytecomp/ bytecode compiler and linker byterun/ bytecode interpreter and runtime system - camlp4/ the Camlp4 preprocessor config/ autoconfiguration stuff debugger/ source-level replay debugger driver/ driver code for the compilers diff --git a/README.win32 b/README.win32 index 00006dd4..111c9a10 100644 --- a/README.win32 +++ b/README.win32 @@ -62,24 +62,12 @@ The native-code compiler (ocamlopt) requires the Microsoft Windows SDK Statically linking OCaml bytecode with C code (ocamlc -custom) also requires items [1] and [2]. -The LablTk GUI requires Tcl/Tk 8.5 (item [3]). - INSTALLATION: The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. -To run programs that use the LablTK GUI, the directory where the -DLLs tk85.dll and tcl85.dll were installed (by the Tcl/Tk -installer) must be added to the PATH environment variable. - -To compile programs that use the LablTK GUI, the directory where the -libraries tk85.lib and tcl85.lib were installed (by the Tcl/Tk -installer) must be added to the library search path in the LIB -environment variable. E.g. if Tcl/Tk was installed in C:\Tcl, add -"C:\Tcl\lib" to the LIB environment variable. - THIRD-PARTY SOFTWARE: [1] Microsoft Windows SDK for Windows 7 and .NET Framework 3.5 Service Pack 1. @@ -90,9 +78,6 @@ THIRD-PARTY SOFTWARE: [2] flexdll version 0.31 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html -[3] TCL/TK version 8.5. Windows binaries are available as part of the - ActiveTCL distribution at http://www.activestate.com/activetcl/downloads - RECOMPILATION FROM THE SOURCES: The command-line tools can be recompiled from the Unix source @@ -101,9 +86,7 @@ for Windows. You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, Vista, or 7 (32 or 64 bits). -- Items [1], [2] and [3] from the list of recommended software above. - Make sure to install the 32-bit version of TCL/TK, even if you are - compiling on a 64-bit Windows. +- Items [1] and [2] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ Install at least the following packages (and their dependencies): diffutils, dos2unix, gcc-core, make, ncurses. @@ -124,9 +107,8 @@ to adjust the paths accordingly. set FLEXDLLDIR=%PFPATH%\flexdll vcvars32 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv - echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv - echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%;C:\Tcl\include" >>C:\cygwin\tmp\msenv + echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >>C:\cygwin\tmp\msenv echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv @@ -148,9 +130,8 @@ directory of the OCaml distribution. Then, do cp config/Makefile.msvc config/Makefile Then, edit config/Makefile as needed, following the comments in this file. -Normally, the only variables that need to be changed are +Normally, the only variable that need to be changed is PREFIX where to install everything - TK_ROOT where TCL/TK was installed Finally, use "make -f Makefile.nt" to build the system, e.g. @@ -168,7 +149,7 @@ performance of bytecode programs is about 2/3 of that obtained under Unix/GCC or Cygwin or Mingw on similar hardware. * Libraries available in this port: "num", "str", "threads", "graphics", -"labltk", and large parts of "unix". +and large parts of "unix". * The replay debugger is partially supported (no reverse execution). @@ -224,27 +205,11 @@ NOTES: (http://mingw-w64.sourceforge.net/) is not supported. Please use the version packaged in Cygwin instead. -The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available -as part of the ActiveTCL distribution at - http://www.activestate.com/activetcl/downloads -Note that you will need to install the 32-bit version of ActiveTCL, -even if you are on a 64-bit version of Windows. - INSTALLATION: The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. -To run programs that use the LablTK GUI, the directory where the -DLLs tk85.dll and tcl85.dll were installed (by the Tcl/Tk -installer) must be added to the PATH environment variable. - -To compile programs that use the LablTK GUI, the directory where the -libraries tk85.lib and tcl85.lib were installed (by the Tcl/Tk -installer) must be added to the library search path in the LIB -environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add -"C:\tcl\lib" to the LIB environment variable. - RECOMPILATION FROM THE SOURCES: @@ -260,7 +225,6 @@ You will need the following software components to perform the recompilation: diffutils make ncurses -- Tcl/Tk version 8.5 (see above). - The flexdll tool (see above). Do not forget to add the flexdll directory to your PATH @@ -277,9 +241,8 @@ directory of the OCaml distribution. Then, do cp config/Makefile.mingw config/Makefile Then, edit config/Makefile as needed, following the comments in this file. -Normally, the only variables that need to be changed are +Normally, the only variable that need to be changed is PREFIX where to install everything - TK_ROOT where Tcl/Tk was installed Finally, use "make -f Makefile.nt" to build the system, e.g. @@ -293,10 +256,16 @@ Finally, use "make -f Makefile.nt" to build the system, e.g. NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", - "labltk", and large parts of "unix". + and large parts of "unix". * The replay debugger is partially supported (no reverse execution). +* The default Makefile.mingw passes -static-libgcc to the linker. + For more information on this topic: + + http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options + http://caml.inria.fr/mantis/view.php?id=6411 + ------------------------------------------------------------------------------ The Cygwin port of OCaml @@ -334,8 +303,8 @@ launch the C compiler. In order to recompile flexdll, you first need to configure, compile, and install OCaml without flexdll support (configure with options --no-shared-libs -no-tk -no-camlp4), then modify the flexdll Makefile -to change line 51 from: +-no-shared-libs), then modify the flexdll Makefile to change +line 51 from: LINKFLAGS = -ccopt "-link version_res.o" to: LINKFLAGS = -cclib version_res.o @@ -356,9 +325,9 @@ NOTES: - The replay debugger is fully supported. - When upgrading from 3.12.0 to 3.12.1, you will need to remove /usr/local/bin/ocamlmktop.exe before typing "make install". -- In order to use the "graph" and "labltk" libraries, you will need - to use Cygwin's setup.exe to install the xinit, libX11-devel, tcl, - and tcl-tk packages before compiling OCaml. +- In order to use the "graph" library, you will need to use Cygwin's + setup.exe to install the xinit, and libX11-devel packages before compiling + OCaml. ------------------------------------------------------------------------------ @@ -380,8 +349,6 @@ Microsoft Platform SDK compiler (item [1] in the section The native-code compiler (ocamlopt) requires the Microsoft compiler and the Microsoft assembler MASM64 (item [1]) and the flexdll tool (item [2]). -The LablTk GUI is not available in this version. - INSTALLATION: There is no binary distribution yet. Please compile from sources as @@ -421,9 +388,7 @@ to adjust the paths accordingly. cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin" vcvars64 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv - echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv - echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv diff --git a/VERSION b/VERSION index d6ae7090..da8c290a 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -4.01.0 +4.02.0 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/_tags b/_tags deleted file mode 100644 index 0f1b6f66..00000000 --- a/_tags +++ /dev/null @@ -1,98 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# Ocamlbuild tags file - -true: -traverse - -# Traverse only these directories -<{bytecomp,driver,stdlib,tools,asmcomp,camlp4,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse - -"boot" or "byterun" or "asmrun" or "compilerlibs": not_hygienic - -# These should not be required but it fails on *BSD and Windows... -"yacc" or "win32caml": not_hygienic - -# We want -g everywhere it's possible -true: debug - -# By default everything we link needs the stdlib -true: use_stdlib - -# The stdlib neither requires the stdlib nor debug information -: -use_stdlib, -debug - -<**/*.ml*>: warn_error_A - -<{bytecomp,driver,stdlib,tools,asmcomp,toplevel,typing,utils,lex,parsing}/**>: strict_sequence - -"toplevel/topstart.byte": linkall - -: -debug -: ocamldoc_sources -: include_unix, include_str, include_dynlink -: use_unix, use_str, use_dynlink - -: camlp4boot, warn_Z -: -camlp4boot -"camlp4/Camlp4_import.ml": -warn_Z - or or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Z, warn_a - or : use_dynlink -: include_unix -"camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink -: include_toplevel -: -debug - -: include_unix - -<**/pervasives.ml> or <**/pervasives.mli> or <**/camlinternalOO.mli>: nopervasives -<**/camlinternalOO*.cmx>: inline(0) -<**/scanf*.cmx>: inline(9) -<**/*Labels.ml*>: nolabels - -"tools/addlabels.ml": warn_s - - or : use_unix, linkall -: include_unix - - or : ocamlmklib - or : ocamlmklib -: ocamlmklib -: ocamlmklib -"otherlibs/threads/unix.cma": ocamlmklib -: ocamlmklib - -: include_unix - -# See the remark about static linking of threads.cmxa in myocamlbuild.ml -: ocamlmklib - -"otherlibs/threads/pervasives.ml": include_unix - -: otherlibs -: otherlibs_unix -: otherlibs_win32unix -: otherlibs_bigarray -: otherlibs_num -: otherlibs_threads -"otherlibs/threads/unix.cma": -otherlibs_threads -: otherlibs_systhreads -: otherlibs_dbm -: otherlibs_graph -: otherlibs_win32graph -: otherlibs_labltk - - or : bootstrap_thread -: ocamlmklib -"otherlibs/labltk/browser/jglib.cma": -ocamlmklib -"otherlibs/labltk/browser/main.byte": use_unix, use_str, ocamlbrowser, bootstrap_thread -: include_unix, include_str diff --git a/asmcomp/.ignore b/asmcomp/.ignore index 31d00178..8c24e74a 100644 --- a/asmcomp/.ignore +++ b/asmcomp/.ignore @@ -4,3 +4,4 @@ proc.ml selection.ml reload.ml scheduling.ml +CSE.ml diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml new file mode 100644 index 00000000..8cd23b0a --- /dev/null +++ b/asmcomp/CSEgen.ml @@ -0,0 +1,322 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +open Mach + +type valnum = int + +(* We maintain sets of equations of the form + valnums = operation(valnums) + plus a mapping from registers to valnums (value numbers). *) + +type rhs = operation * valnum array + +module Equations = + Map.Make(struct type t = rhs let compare = Pervasives.compare end) + +type numbering = + { num_next: int; (* next fresh value number *) + num_eqs: valnum array Equations.t; (* mapping rhs -> valnums *) + num_reg: valnum Reg.Map.t } (* mapping register -> valnum *) + +let empty_numbering = + { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty } + +(** Generate a fresh value number [v] and associate it to register [r]. + Returns a pair [(n',v)] with the updated value numbering [n']. *) + +let fresh_valnum_reg n r = + let v = n.num_next in + ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v) + +(* Same, for a set of registers [rs]. *) + +let array_fold_transf (f: numbering -> 'a -> numbering * 'b) n (a: 'a array) + : numbering * 'b array = + match Array.length a with + | 0 -> (n, [||]) + | 1 -> let (n', b) = f n a.(0) in (n', [|b|]) + | l -> let b = Array.make l 0 and n = ref n in + for i = 0 to l - 1 do + let (n', x) = f !n a.(i) in + b.(i) <- x; n := n' + done; + (!n, b) + +let fresh_valnum_regs n rs = + array_fold_transf fresh_valnum_reg n rs + +(** [valnum_reg n r] returns the value number for the contents of + register [r]. If none exists, a fresh value number is returned + and associated with register [r]. The possibly updated numbering + is also returned. [valnum_regs] is similar, but for an array of + registers. *) + +let valnum_reg n r = + try + (n, Reg.Map.find r n.num_reg) + with Not_found -> + fresh_valnum_reg n r + +let valnum_regs n rs = + array_fold_transf valnum_reg n rs + +(* Look up the set of equations for an equation with the given rhs. + Return [Some res] if there is one, where [res] is the lhs. *) + +let find_equation n rhs = + try + Some(Equations.find rhs n.num_eqs) + with Not_found -> + None + +(* Find a register containing the given value number. *) + +let find_reg_containing n v = + Reg.Map.fold (fun r v' res -> if v' = v then Some r else res) + n.num_reg None + +(* Find a set of registers containing the given value numbers. *) + +let find_regs_containing n vs = + match Array.length vs with + | 0 -> Some [||] + | 1 -> begin match find_reg_containing n vs.(0) with + | None -> None + | Some r -> Some [|r|] + end + | l -> let rs = Array.make l Reg.dummy in + begin try + for i = 0 to l - 1 do + match find_reg_containing n vs.(i) with + | None -> raise Exit + | Some r -> rs.(i) <- r + done; + Some rs + with Exit -> + None + end + +(* Associate the given value number to the given result register, + without adding new equations. *) + +let set_known_reg n r v = + { n with num_reg = Reg.Map.add r v n.num_reg } + +(* Associate the given value numbers to the given result registers, + without adding new equations. *) + +let array_fold2 f n a1 a2 = + let l = Array.length a1 in + assert (l = Array.length a2); + let n = ref n in + for i = 0 to l - 1 do n := f !n a1.(i) a2.(i) done; + !n + +let set_known_regs n rs vs = + array_fold2 set_known_reg n rs vs + +(* Record the effect of a move: no new equations, but the result reg + maps to the same value number as the argument reg. *) + +let set_move n src dst = + let (n1, v) = valnum_reg n src in + { n1 with num_reg = Reg.Map.add dst v n1.num_reg } + +(* Record the equation [fresh valnums = rhs] and associate the given + result registers [rs] to [fresh valnums]. *) + +let set_fresh_regs n rs rhs = + let (n1, vs) = fresh_valnum_regs n rs in + { n1 with num_eqs = Equations.add rhs vs n.num_eqs } + +(* Forget everything we know about the given result registers, + which are receiving unpredictable values at run-time. *) + +let set_unknown_regs n rs = + { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg } + +(* Keep only the equations satisfying the given predicate. *) + +let filter_equations pred n = + { n with num_eqs = Equations.filter (fun (op,_) res -> pred op) n.num_eqs } + +(* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) + +let insert_single_move i src dst = instr_cons (Iop Imove) [|src|] [|dst|] i + +let insert_move srcs dsts i = + match Array.length srcs with + | 0 -> i + | 1 -> instr_cons (Iop Imove) srcs dsts i + | l -> (* Parallel move: first copy srcs into tmps one by one, + then copy tmps into dsts one by one *) + let tmps = Reg.createv_like srcs in + array_fold2 insert_single_move + (array_fold2 insert_single_move i srcs tmps) tmps dsts + +(* Classification of operations *) + +type op_class = + | Op_pure (* pure arithmetic, produce one or several result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic = object (self) + +(* Default classification of operations. Can be overriden in + processor-specific files to classify specific operations better. *) + +method class_of_operation op = + match op with + | Imove | Ispill | Ireload -> assert false (* treated specially *) + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ + | Iconst_blockheader _ -> Op_pure + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ -> assert false (* treated specially *) + | Istackoffset _ -> Op_other + | Iload(_,_) -> Op_load + | Istore(_,_,asg) -> Op_store asg + | Ialloc _ -> assert false (* treated specially *) + | Iintop(Icheckbound) -> Op_checkbound + | Iintop _ -> Op_pure + | Iintop_imm(Icheckbound, _) -> Op_checkbound + | Iintop_imm(_, _) -> Op_pure + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> Op_pure + | Ispecific _ -> Op_other + +(* Operations that are so cheap that it isn't worth factoring them. *) + +method is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | _ -> false + +(* Forget all equations involving memory loads. Performed after a + non-initializing store *) + +method private kill_loads n = + filter_equations (fun o -> self#class_of_operation o <> Op_load) n + +(* Perform CSE on the given instruction [i] and its successors. + [n] is the value numbering current at the beginning of [i]. *) + +method private cse n i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) + | Iexit _ | Iraise _ -> + i + | Iop (Imove | Ispill | Ireload) -> + (* For moves, we associate the same value number to the result reg + as to the argument reg. *) + let n1 = set_move n i.arg.(0) i.res.(0) in + {i with next = self#cse n1 i.next} + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + (* For function calls, we should at least forget: + - equations involving memory loads, since the callee can + perform arbitrary memory stores; + - equations involving arithmetic operations that can + produce bad pointers into the heap (see below for Ialloc); + - mappings from hardware registers to value numbers, + since the callee does not preserve these registers. + That doesn't leave much usable information: checkbounds + could be kept, but won't be usable for CSE as one of their + arguments is always a memory load. For simplicity, we + just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop (Ialloc _) -> + (* For allocations, we must avoid extending the live range of a + pseudoregister across the allocation if this pseudoreg can + contain a value that looks like a pointer into the heap but + is not a pointer to the beginning of a Caml object. PR#6484 + is an example of such a value (a derived pointer into a + block). In the absence of more precise typing information, + we just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop op -> + begin match self#class_of_operation op with + | Op_pure | Op_checkbound | Op_load -> + let (n1, varg) = valnum_regs n i.arg in + let n2 = set_unknown_regs n1 (Proc.destroyed_at_oper i.desc) in + begin match find_equation n1 (op, varg) with + | Some vres -> + (* This operation was computed earlier. *) + (* Are there registers that hold the results computed earlier? *) + begin match find_regs_containing n1 vres with + | Some res when (not (self#is_cheap_operation op)) + && (not (Proc.regs_are_volatile res)) -> + (* We can replace res <- op args with r <- move res, + provided res are stable (non-volatile) registers. + If the operation is very cheap to compute, e.g. + an integer constant, don't bother. *) + let n3 = set_known_regs n1 i.res vres in + (* This is n1 above and not n2 because the move + does not destroy any regs *) + insert_move res i.res (self#cse n3 i.next) + | _ -> + (* We already computed the operation but lost its + results. Associate the result registers to + the result valnums of the previous operation. *) + let n3 = set_known_regs n2 i.res vres in + {i with next = self#cse n3 i.next} + end + | None -> + (* This operation produces a result we haven't seen earlier. *) + let n3 = set_fresh_regs n2 i.res (op, varg) in + {i with next = self#cse n3 i.next} + end + | Op_store false | Op_other -> + (* An initializing store or an "other" operation do not invalidate + any equations, but we do not know anything about the results. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + {i with next = self#cse n2 i.next} + | Op_store true -> + (* A non-initializing store can invalidate + anything we know about prior loads. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + let n3 = self#kill_loads n2 in + {i with next = self#cse n3 i.next} + end + (* For control structures, we set the numbering to empty at every + join point, but propagate the current numbering across fork points. *) + | Iifthenelse(test, ifso, ifnot) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iifthenelse(test, self#cse n1 ifso, self#cse n1 ifnot); + next = self#cse empty_numbering i.next} + | Iswitch(index, cases) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iswitch(index, Array.map (self#cse n1) cases); + next = self#cse empty_numbering i.next} + | Iloop(body) -> + {i with desc = Iloop(self#cse empty_numbering body); + next = self#cse empty_numbering i.next} + | Icatch(nfail, body, handler) -> + {i with desc = Icatch(nfail, self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + | Itrywith(body, handler) -> + {i with desc = Itrywith(self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + +method fundecl f = + {f with fun_body = self#cse empty_numbering f.fun_body} + +end diff --git a/asmcomp/CSEgen.mli b/asmcomp/CSEgen.mli new file mode 100644 index 00000000..0b375ff5 --- /dev/null +++ b/asmcomp/CSEgen.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic : object + (* The following methods can be overriden to handle processor-specific + operations. *) + + method class_of_operation: Mach.operation -> op_class + + method is_cheap_operation: Mach.operation -> bool + (* Operations that are so cheap that it isn't worth factoring them. *) + + (* The following method is the entry point and should not be overridden *) + method fundecl: Mach.fundecl -> Mach.fundecl + +end diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml new file mode 100644 index 00000000..aee43d2b --- /dev/null +++ b/asmcomp/amd64/CSE.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the AMD64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific spec -> + begin match spec with + | Ilea _ -> Op_pure + | Istore_int(_, _, is_asg) | Istore_symbol(_, _, is_asg) -> Op_store is_asg + | Ioffset_loc(_, _) -> Op_store true + | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load + | Ibswap _ | Isqrtf -> super#class_of_operation op + end + | _ -> super#class_of_operation op + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index b0a5ffb8..a4f1abd9 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -33,8 +33,9 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) @@ -101,10 +102,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Isqrtf -> diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 8dad2206..b576ece9 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -22,6 +22,7 @@ open Emitaux let macosx = (Config.system = "macosx") let mingw64 = (Config.system = "mingw64") +let cygwin = (Config.system = "cygwin") let fp = Config.with_frame_pointers @@ -61,17 +62,17 @@ let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` let load_symbol_addr s = - if !Clflags.dlcode && not mingw64 + if !Clflags.dlcode && not mingw64 && not cygwin then `movq {emit_symbol s}@GOTPCREL(%rip)` else if !pic_code then `leaq {emit_symbol s}(%rip)` @@ -334,15 +335,16 @@ let output_epilogue f = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -372,7 +374,7 @@ let emit_instr fallthrough i = | _ -> ` movq {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -381,12 +383,12 @@ let emit_instr fallthrough i = ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` else ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> @@ -447,7 +449,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -514,6 +516,8 @@ let emit_instr fallthrough i = | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` imulq {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` @@ -523,22 +527,6 @@ let emit_instr fallthrough i = ` incq {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` addq ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - ` testq %rax, %rax\n`; - ` cmovns %rax, {emit_reg i.arg.(0)}\n`; - ` sarq ${emit_int l}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` testq %rax, %rax\n`; - ` leaq {emit_int(n-1)}(%rax), %rax\n`; - ` cmovns {emit_reg i.arg.(0)}, %rax\n`; - ` andq ${emit_int (-n)}, %rax\n`; - ` subq %rax, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` @@ -554,9 +542,9 @@ let emit_instr fallthrough i = ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -650,7 +638,7 @@ let emit_instr fallthrough i = ` jmp *{emit_reg tmp1}\n`; if macosx then ` .const\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata\n`; @@ -674,11 +662,16 @@ let emit_instr fallthrough i = ` addq $8, %rsp\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` {emit_call "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` {emit_call "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` movq %r14, %rsp\n`; ` popq %r14\n`; ` ret\n` @@ -772,9 +765,9 @@ let emit_item = function | Cint n -> ` .quad {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_directive ".quad" f + emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> @@ -799,7 +792,7 @@ let begin_assembly() = (* from amd64.S; could emit these constants on demand *) if macosx then ` .literal16\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; @@ -822,7 +815,7 @@ let end_assembly() = if !float_constants <> [] then begin if macosx then ` .literal8\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index c38c21f2..f14e69cd 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -15,7 +15,6 @@ module StringSet = Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Misc open Cmm open Arch open Proc @@ -24,6 +23,8 @@ open Mach open Linearize open Emitaux +let rdx = phys_reg 4 + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -52,9 +53,10 @@ let slot_offset loc cl = else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n -(* Output a 32 bit integer in hex *) +(* Output a 32 or 64 bit integer in hex *) let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Symbols *) @@ -320,36 +322,24 @@ let output_epilogue () = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` + +let emit_movabs reg n = + (* force ml64 to use mov reg, imm64 instruction *) + ` mov {emit_reg reg}, {emit_printf "0%nxH" n}\n` (* Output the assembly code for an instruction *) @@ -372,7 +362,7 @@ let emit_instr fallthrough i = | _ -> ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -383,14 +373,13 @@ let emit_instr fallthrough i = (* work around bug in ml64 *) ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` else - (* force ml64 to use mov reg, imm64 instruction *) - ` mov {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + emit_movabs i.res.(0) n + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -454,7 +443,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -517,6 +506,8 @@ let emit_instr fallthrough i = | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop Imulh) -> + ` imul {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` @@ -526,22 +517,6 @@ let emit_instr fallthrough i = ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - ` test rax, rax\n`; - ` cmovns {emit_reg i.arg.(0)}, rax\n`; - ` sar {emit_reg i.res.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` test rax, rax\n`; - ` lea rax, {emit_int(n-1)}[rax]\n`; - ` cmovns rax, {emit_reg i.arg.(0)}\n`; - ` and rax, {emit_int (-n)}\n`; - ` sub {emit_reg i.res.(0)}, rax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` @@ -557,9 +532,9 @@ let emit_instr fallthrough i = ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code); add_used_symbol s; ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` @@ -666,11 +641,16 @@ let emit_instr fallthrough i = ` pop r14\n`; ` add rsp, 8\n`; stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call caml_reraise_exn\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` mov rsp, r14\n`; ` pop r14\n`; ` ret\n` @@ -726,9 +706,9 @@ let emit_item = function | Cint n -> ` QWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s; ` QWORD {emit_symbol s}\n` @@ -762,6 +742,7 @@ let begin_assembly() = ` EXTRN caml_alloc3: NEAR\n`; ` EXTRN caml_ml_array_bound_error: NEAR\n`; ` EXTRN caml_raise_exn: NEAR\n`; + ` EXTRN caml_reraise_exn: NEAR\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; ` .DATA\n`; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 8774a0da..298e9290 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -24,7 +24,7 @@ let fp = Config.with_frame_pointers let win64 = match Config.system with - | "win64" | "mingw64" -> true + | "win64" | "mingw64" | "cygwin" -> true | _ -> false (* Which asm conventions to use *) @@ -117,12 +117,12 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 13 Reg.dummy in + let v = Array.make 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 16 Reg.dummy in + let v = Array.make 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v @@ -149,7 +149,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -210,7 +210,7 @@ let win64_float_external_arguments = [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do @@ -239,6 +239,10 @@ let loc_external_arguments = let loc_exn_bucket = rax +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -257,9 +261,10 @@ let destroyed_at_c_call = let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] - | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) + | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) + -> [| rax; rdx |] + | Iop(Istore(Single, _, _)) -> [| rxmm15 |] + | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] | _ -> @@ -285,14 +290,25 @@ let max_register_pressure = function if fp then [| 7; 10 |] else [| 8; 10 |] else if fp then [| 3; 0 |] else [| 4; 0 |] - | Iintop(Idiv | Imod) -> + | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) -> if fp then [| 10; 16 |] else [| 11; 16 |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> if fp then [| 11; 16 |] else [| 12; 16 |] - | Istore(Single, _) -> + | Istore(Single, _, _) -> if fp then [| 12; 15 |] else [| 13; 15 |] | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 510f201f..49070d29 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -22,7 +22,8 @@ open Mach Operation Res Arg1 Arg2 Imove R S or S R - Iconst_int S if 32-bit signed, R otherwise + Iconst_int ] S if 32-bit signed, R otherwise + Iconst_blockheader ] Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R @@ -32,7 +33,8 @@ open Mach Istore R R Iintop(Icomp) R R S or S S R - Iintop(Imul|Idiv|mod) R R S + Iintop(Imul|Idiv|Imod) R R S + Iintop(Imulh) R R S Iintop(shift) S S R Iintop(others) R R S or S S R @@ -71,10 +73,10 @@ method! reload_operation op arg res = (* This add will be turned into a lea; args and results must be in registers *) super#reload_operation op arg res - | Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr) + | Iintop(Imulh | Idiv | Imod | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) -> (* The argument(s) and results can be either in register or on stack *) - (* Note: Idiv, Imod: arg(0) and res(0) already forced in regs + (* Note: Imulh, Idiv, Imod: arg(0) and res(0) already forced in regs Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf -> @@ -86,7 +88,7 @@ method! reload_operation op arg res = | Ifloatofint | Iintoffloat -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) - | Iconst_int n -> + | Iconst_int n | Iconst_blockheader n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) else super#reload_operation op arg res diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 4de84128..fa7fe66c 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -91,6 +91,10 @@ let pseudoregs_for_operation op arg res = (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) | Ispecific(Ibswap 16) -> ([| rax |], [| rax |]) + (* For imulq, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Iintop(Imulh) -> + ([| rax; arg.(1) |], [| rdx |]) | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); @@ -105,10 +109,6 @@ let pseudoregs_for_operation op arg res = ([| rax; rcx |], [| rax |]) | Iintop(Imod) -> ([| rax; rcx |], [| rdx |]) - (* For div and mod with immediate operand, arg must not be in rax. - Keep it simple, force it in rdx. *) - | Iintop_imm((Idiv|Imod), _) -> - ([| rdx |], [| rdx |]) (* Other instructions are regular *) | _ -> raise Use_default @@ -152,20 +152,20 @@ method select_addressing chunk exp = | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -176,21 +176,6 @@ method! select_operation op args = | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. *) | Caddf -> self#select_floatarith true Iaddf Ifloatadd args @@ -227,6 +212,9 @@ method! select_operation op args = | Cextcall("caml_int64_direct_bswap", _, _, _) | Cextcall("caml_nativeint_direct_bswap", _, _, _) -> (Ispecific (Ibswap 64), args) + (* AMD64 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) | _ -> super#select_operation op args (* Recognize float arithmetic with mem *) @@ -246,6 +234,9 @@ method select_floatarith commutative regular_op mem_op args = | _ -> assert false +method! mark_c_tailcall = + Proc.contains_calls := true + (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml new file mode 100644 index 00000000..bea333dc --- /dev/null +++ b/asmcomp/arm/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index cac286aa..d93c1e0e 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -21,7 +21,7 @@ type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3 let abi = match Config.system with - "linux_eabi" -> EABI + "linux_eabi" | "freebsd" -> EABI | "linux_eabihf" -> EABI_HF | _ -> assert false @@ -107,9 +107,10 @@ type addressing_mode = (* Specific operations *) type specific_operation = - Ishiftarith of arith_operation * int - | Ishiftcheckbound of int + Ishiftarith of arith_operation * shift_operation * int + | Ishiftcheckbound of shift_operation * int | Irevsubimm of int + | Imulhadd (* multiply high and add *) | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -124,6 +125,14 @@ and arith_operation = Ishiftadd | Ishiftsub | Ishiftsubrev + | Ishiftand + | Ishiftor + | Ishiftxor + +and shift_operation = + Ishiftlogicalleft + | Ishiftlogicalright + | Ishiftarithmeticright (* Sizes, endianness *) @@ -155,23 +164,41 @@ let print_addressing printreg addr ppf arg = printreg ppf arg.(0); if n <> 0 then fprintf ppf " + %i" n +let shiftop_name = function + | Ishiftlogicalleft -> "<<" + | Ishiftlogicalright -> ">>u" + | Ishiftarithmeticright -> ">>s" + let print_specific_operation printreg op ppf arg = match op with - | Ishiftarith(op, shift) -> - let op_name = function - | Ishiftadd -> "+" - | Ishiftsub -> "-" - | Ishiftsubrev -> "-rev" in - let shift_mark = - if shift >= 0 - then sprintf "<< %i" shift - else sprintf ">> %i" (-shift) in - fprintf ppf "%a %s %a %s" - printreg arg.(0) (op_name op) printreg arg.(1) shift_mark - | Ishiftcheckbound n -> - fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + Ishiftarith(op, shiftop, amount) -> + let (op1_name, op2_name) = match op with + Ishiftadd -> ("", "+") + | Ishiftsub -> ("", "-") + | Ishiftsubrev -> ("-", "+") + | Ishiftand -> ("", "&") + | Ishiftor -> ("", "|") + | Ishiftxor -> ("", "^") in + fprintf ppf "%s%a %s (%a %s %i)" + op1_name + printreg arg.(0) + op2_name + printreg arg.(1) + (shiftop_name shiftop) + amount + | Ishiftcheckbound(shiftop, amount) -> + fprintf ppf "check (%a %s %i) > %a" + printreg arg.(0) + (shiftop_name shiftop) + amount + printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) + | Imulhadd -> + fprintf ppf "%a *h %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 4a126151..61035b85 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -173,19 +173,23 @@ let name_for_comparison = function | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Imul -> "mul" - | Iand -> "and" - | Ior -> "orr" - | Ixor -> "eor" + (* Use adds,subs,... to enable 16-bit T1 encoding *) + Iadd -> "adds" + | Isub -> "subs" + | Imul -> "mul" + | Imulh -> "smmul" + | Iand -> "ands" + | Ior -> "orrs" + | Ixor -> "eors" + | Ilsl -> "lsls" + | Ilsr -> "lsrs" + | Iasr -> "asrs" | _ -> assert false let name_for_shift_operation = function - Ilsl -> "lsl" - | Ilsr -> "lsr" - | Iasr -> "asr" - | _ -> assert false + Ishiftlogicalleft -> "lsl" + | Ishiftlogicalright -> "lsr" + | Ishiftarithmeticright -> "asr" (* General functional to decompose a non-immediate integer constant into 8-bit chunks shifted left 0 ... 30 bits. *) @@ -233,8 +237,9 @@ let emit_intconst dst n = decompose_intconst n (fun bits -> if !first - then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` - else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; + (* Use movs,adds here to enable 16-bit T1 encoding *) + then ` movs {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` + else ` adds {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end @@ -268,7 +273,7 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) -let float_literals = ref ([] : (string * label) list) +let float_literals = ref ([] : (int64 * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) @@ -278,12 +283,13 @@ let num_literals = ref 0 (* Label a floating-point literal *) let float_literal f = + let repr = Int64.bits_of_float f in try - List.assoc f !float_literals + List.assoc repr !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; - float_literals := (f, lbl) :: !float_literals; + float_literals := (repr, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) @@ -309,7 +315,7 @@ let emit_literals() = ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .double {emit_string f}\n`) + `{emit_label lbl}:`; emit_float64_split_directive ".long" f) !float_literals; float_literals := [] end; @@ -382,11 +388,10 @@ let emit_instr i = ` ldr {emit_reg dst}, {emit_stack src}\n` end; 1 end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - ` @ {emit_string f}\n`; - let bits = Int64.bits_of_float (float_of_string f) in + let bits = Int64.bits_of_float f in let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) and low_bits = Int64.to_int32 bits in if is_immediate low_bits || is_immediate high_bits then begin @@ -401,7 +406,7 @@ let emit_instr i = end | Lop(Iconst_float f) when !fpu = VFPv2 -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n`; 1 | Lop(Iconst_float f) -> let encode imm = @@ -420,12 +425,12 @@ let emit_instr i = let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float (float_of_string f)) with + begin match encode (Int64.bits_of_float f) with None -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` | Some imm8 -> - ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -503,10 +508,10 @@ let emit_instr i = | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> + | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 - | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 @@ -520,7 +525,7 @@ let emit_instr i = ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let r = i.arg.(0) in let instr = match size with @@ -562,9 +567,6 @@ let emit_instr i = `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 1 + ninstr end - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> let compthen = name_for_comparison cmp in let compelse = name_for_comparison (negate_integer_comparison cmp) in @@ -587,45 +589,21 @@ let emit_instr i = let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` bls {emit_label lbl}\n`; 2 - | Lop(Ispecific(Ishiftcheckbound shift)) -> + | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) -> let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + let op = name_for_shift_operation shiftop in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, {emit_string op} #{emit_int n}\n`; ` bcs {emit_label lbl}\n`; 2 + | Lop(Iintop Imulh) when !arch < ARMv6 -> + ` smull r12, {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + | Lop(Ispecific Imulhadd) -> + ` smmla {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lop(Iintop op) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 - | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let r = i.res.(0) in - ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; - if n <= 256 then begin - ` it lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` - end else begin - ` itt lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - ` sublt {emit_reg r}, {emit_reg r}, #1\n` - end; - ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let a = i.arg.(0) in - let r = i.res.(0) in - let lbl = new_label() in - ` cmp {emit_reg a}, #0\n`; - ` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`; - ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; - ` bpl {emit_label lbl}\n`; - ` cmp {emit_reg r}, #0\n`; - ` it ne\n`; - ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - `{emit_label lbl}:\n`; 7 - | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Iabsf | Inegf as op) when !fpu = Soft -> let instr = (match op with Iabsf -> "bic" @@ -664,16 +642,16 @@ let emit_instr i = | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 - | Lop(Ispecific(Ishiftarith(op, shift))) -> + | Lop(Ispecific(Ishiftarith(op, shiftop, n))) -> let instr = (match op with Ishiftadd -> "add" | Ishiftsub -> "sub" - | Ishiftsubrev -> "rsb") in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; - if shift >= 0 - then `, lsl #{emit_int shift}\n` - else `, asr #{emit_int (-shift)}\n`; - 1 + | Ishiftsubrev -> "rsb" + | Ishiftand -> "and" + | Ishiftor -> "orr" + | Ishiftxor -> "eor") in + let op = name_for_shift_operation shiftop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_string op} #{emit_int n}\n`; 1 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Ispecific(Imuladd | Imulsub as op)) -> @@ -803,11 +781,13 @@ let emit_instr i = ` pop \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> ` {emit_call "caml_raise_exn"}\n`; `{record_frame Reg.Set.empty i.dbg}\n`; 1 - end else begin + | false, _ + | true, Lambda.Raise_notrace -> ` mov sp, trap_ptr\n`; ` pop \{trap_ptr, pc}\n`; 2 end @@ -894,8 +874,8 @@ let emit_item = function | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` - | Csingle f -> ` .single {emit_string f}\n` - | Cdouble f -> ` .double {emit_string f}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index dbb13173..6b2ba3cf 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -82,14 +82,14 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 9 Reg.dummy in + let v = Array.make 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -108,7 +108,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -166,13 +166,17 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) Array.of_list (List.map phys_reg [7;8; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131]) let destroyed_at_c_call = @@ -183,12 +187,12 @@ let destroyed_at_c_call = [0;1;2;3;8; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] | EABI_HF -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function @@ -201,7 +205,9 @@ let destroyed_at_oper = function destroyed_at_alloc | Iop(Iconst_symbol _) when !pic_code -> [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintop Imulh) when !arch < ARMv6 -> + [| phys_reg 8 |] (* r12 destroyed *) + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] @@ -220,9 +226,19 @@ let max_register_pressure = function | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] | _ -> [| 9; 16; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index 9e2d65bc..0d6618ab 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -31,8 +31,8 @@ method oper_latency = function | Ifloatofint (* mcr/mrc count as memory access *) | Iintoffloat -> 2 (* Multiplys have a latency of two cycles *) - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop (Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf @@ -58,10 +58,8 @@ method oper_issue_cycles = function | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 6 - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop(Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf -> 7 diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 97f615ec..9cd6090c 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -37,15 +37,18 @@ let is_offset chunk n = | _ -> n >= -255 && n <= 255 -let is_intconst = function - Cconst_int _ -> true - | _ -> false +let select_shiftop = function + Clsl -> Ishiftlogicalleft + | Clsr -> Ishiftlogicalright + | Casr -> Ishiftarithmeticright + | __-> assert false (* Special constraints on operand and result registers *) exception Use_default let r1 = phys_reg 1 +let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = match op with @@ -54,6 +57,11 @@ let pseudoregs_for_operation op arg res = is also a result of the mul / mla operation. *) Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) + (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn + must be different. We deal with this by pretending that rn is also a + result of the smull operation. *) + | Iintop Imulh when !arch < ARMv6 -> + (arg, [| res.(0); arg.(0) |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) @@ -110,24 +118,27 @@ method select_addressing chunk = function | arg -> (Iindexed 0, arg) -method select_shift_arith op shiftop shiftrevop args = +method select_shift_arith op arithop arithrevop args = match args with - [arg1; Cop(Clsl, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, n)), [arg1; arg2]) - | [arg1; Cop(Casr, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, -n)), [arg1; arg2]) - | [Cop(Clsl, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, n)), [arg2; arg1]) - | [Cop(Casr, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) + [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n])] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2]) + | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1]) | args -> begin match super#select_operation op args with + (* Recognize multiply high and add *) + (Iintop Iadd, [Cop(Cmulhi, args); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmulhi, args)]) as op_args + when !arch >= ARMv6 -> + begin match self#select_operation Cmulhi args with + (Iintop Imulh, [arg1; arg2]) -> + (Ispecific Imulhadd, [arg1; arg2; arg3]) + | _ -> op_args + end (* Recognize multiply and add *) - (Iintop Iadd, [Cop(Cmuli, args); arg3]) + | (Iintop Iadd, [Cop(Cmuli, args); arg3]) | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> begin match self#select_operation Cmuli args with (Iintop Imul, [arg1; arg2]) -> @@ -161,21 +172,23 @@ method! select_operation op args = (Ispecific(Irevsubimm n), [arg]) | ((Csuba | Csubi as op), args) -> self#select_shift_arith op Ishiftsub Ishiftsubrev args - | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | (Cand as op, args) -> + self#select_shift_arith op Ishiftand Ishiftand args + | (Cor as op, args) -> + self#select_shift_arith op Ishiftor Ishiftor args + | (Cxor as op, args) -> + self#select_shift_arith op Ishiftxor Ishiftxor args + | (Ccheckbound _, [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2]) + when n > 0 && n < 32 -> + (Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2]) (* ARM does not support immediate operands for multiplication *) | (Cmuli, args) -> (Iintop Imul, args) + | (Cmulhi, args) -> + (Iintop Imulh, args) (* Turn integer division/modulus into runtime ABI calls *) - | (Cdivi, [arg; Cconst_int n]) - when n = 1 lsl Misc.log2 n -> - (Iintop_imm(Idiv, n), [arg]) | (Cdivi, args) -> (Iextcall("__aeabi_idiv", false), args) - | (Cmodi, [arg; Cconst_int n]) - when n > 1 && n = 1 lsl Misc.log2 n -> - (Iintop_imm(Imod, n), [arg]) | (Cmodi, args) -> (* See above for fix up of return register *) (Iextcall("__aeabi_idivmod", false), args) diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml new file mode 100644 index 00000000..f9e03e48 --- /dev/null +++ b/asmcomp/arm64/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml new file mode 100644 index 00000000..bfbe183f --- /dev/null +++ b/asmcomp/arm64/arch.ml @@ -0,0 +1,145 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +let command_line_options = [] + +(* Specific operations for the ARM processor, 64-bit mode *) + +open Format + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + | Iindexed of int (* reg + displ *) + | Ibased of string * int (* global var + displ *) + +(* We do not support the reg + shifted reg addressing mode, because + what we really need is reg + shifted reg + displ, + and this is decomposed in two instructions (reg + shifted reg -> tmp, + then addressing tmp + displ). *) + +(* Specific operations *) + +type specific_operation = + | Ishiftarith of arith_operation * int + | Ishiftcheckbound of int + | Imuladd (* multiply and add *) + | Imulsub (* multiply and subtract *) + | Inegmulf (* floating-point negate and multiply *) + | Imuladdf (* floating-point multiply and add *) + | Inegmuladdf (* floating-point negate, multiply and add *) + | Imulsubf (* floating-point multiply and subtract *) + | Inegmulsubf (* floating-point negate, multiply and subtract *) + | Isqrtf (* floating-point square root *) + | Ibswap of int (* endianess conversion *) + +and arith_operation = + Ishiftadd + | Ishiftsub + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +let allow_unaligned_access = false + +(* Behavior of division *) + +let division_crashes_on_overflow = false + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + | Iindexed n -> Iindexed(n + delta) + | Ibased(s, n) -> Ibased(s, n + delta) + +let num_args_addressing = function + | Iindexed n -> 1 + | Ibased(s, n) -> 0 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + printreg ppf arg.(0); + if n <> 0 then fprintf ppf " + %i" n + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s + | Ibased(s, n) -> + fprintf ppf "\"%s\" + %i" s n + +let print_specific_operation printreg op ppf arg = + match op with + | Ishiftarith(op, shift) -> + let op_name = function + | Ishiftadd -> "+" + | Ishiftsub -> "-" in + let shift_mark = + if shift >= 0 + then sprintf "<< %i" shift + else sprintf ">> %i" (-shift) in + fprintf ppf "%a %s %a %s" + printreg arg.(0) (op_name op) printreg arg.(1) shift_mark + | Ishiftcheckbound n -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + | Imuladd -> + fprintf ppf "(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsub -> + fprintf ppf "-(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulf -> + fprintf ppf "-f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + | Imuladdf -> + fprintf ppf "%a +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmuladdf -> + fprintf ppf "(-f %a) -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsubf -> + fprintf ppf "%a -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulsubf -> + fprintf ppf "(-f %a) +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Isqrtf -> + fprintf ppf "sqrtf %a" + printreg arg.(0) + | Ibswap n -> + fprintf ppf "bswap%i %a" n + printreg arg.(0) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp new file mode 100644 index 00000000..734bd23e --- /dev/null +++ b/asmcomp/arm64/emit.mlp @@ -0,0 +1,736 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Emission of ARM assembly code, 64-bit mode *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Names for special regs *) + +let reg_trap_ptr = phys_reg 23 +let reg_alloc_ptr = phys_reg 24 +let reg_alloc_limit = phys_reg 25 +let reg_tmp1 = phys_reg 26 +let reg_tmp2 = phys_reg 27 +let reg_x15 = phys_reg 15 + +(* Output a label *) + +let emit_label lbl = + emit_string ".L"; emit_int lbl + +let emit_data_label lbl = + emit_string ".Ld"; emit_int lbl + +(* Symbols *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg = function + {loc = Reg r} -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +(* Likewise, but with the 32-bit name of the register *) + +let int_reg_name_w = + [| "w0"; "w1"; "w2"; "w3"; "w4"; "w5"; "w6"; "w7"; + "w8"; "w9"; "w10"; "w11"; "w12"; "w13"; "w14"; "w15"; + "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25"; + "w26"; "w27"; "w28"; "w16"; "w17" |] + +let emit_wreg = function + {loc = Reg r} -> emit_string int_reg_name_w.(r) + | _ -> fatal_error "Emit.emit_wreg" + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + let sz = + !stack_offset + + 8 * num_stack_slots.(0) + + 8 * num_stack_slots.(1) + + (if !contains_calls then 8 else 0) + in Misc.align sz 16 + +let slot_offset loc cl = + match loc with + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + !stack_offset + + (if cl = 0 + then n * 8 + else num_stack_slots.(0) * 8 + n * 8) + | Outgoing n -> + assert (n >= 0); + n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + | Stack s -> + let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` + | _ -> fatal_error "Emit.emit_stack" + +(* Output an addressing mode *) + +let emit_symbol_offset s ofs = + emit_symbol s; + if ofs > 0 then `+{emit_int ofs}` + else if ofs < 0 then `-{emit_int (-ofs)}` + else () + +let emit_addressing addr r = + match addr with + | Iindexed ofs -> + `[{emit_reg r}, #{emit_int ofs}]` + | Ibased(s, ofs) -> + `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]` + +(* Record live pointers at call points *) + +let record_frame_label live dbg = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: bl {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In debug mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Otherwise, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame_lbl: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) + +let bound_error_label dbg = + if !Clflags.debug || !bound_error_sites = [] then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; + bd_frame_lbl = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + let bd = List.hd !bound_error_sites in bd.bd_lbl + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: bl {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame_lbl}:\n` + +(* Names of various instructions *) + +let name_for_comparison = function + | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" + | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" + | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" + +let name_for_int_operation = function + | Iadd -> "add" + | Isub -> "sub" + | Imul -> "mul" + | Idiv -> "sdiv" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" + | Ilsl -> "lsl" + | Ilsr -> "lsr" + | Iasr -> "asr" + | _ -> assert false + +(* Load an integer constant into a register *) + +let emit_intconst dst n = + let rec emit_pos first shift = + if shift < 0 then begin + if first then ` mov {emit_reg dst}, xzr\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then emit_pos first (shift - 16) else begin + if first then + ` movz {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_pos false (shift - 16) + end + end + and emit_neg first shift = + if shift < 0 then begin + if first then ` movn {emit_reg dst}, #0\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then emit_neg first (shift - 16) else begin + if first then + ` movn {emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_neg false (shift - 16) + end + end + in + if n < 0n then emit_neg true 48 else emit_pos true 48 + +(* Recognize float constants appropriate for FMOV dst, #fpimm instruction: + "a normalized binary floating point encoding with 1 sign bit, 4 + bits of fraction and a 3-bit exponent" *) + +let is_immediate_float bits = + let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in + let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in + exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant + +(* Adjust sp (up or down) by the given byte amount *) + +let emit_stack_adjustment n = + let instr = if n < 0 then "sub" else "add" in + let m = abs n in + assert (m < 0x1_000_000); + let ml = m land 0xFFF and mh = m land 0xFFF_000 in + if mh <> 0 then ` {emit_string instr} sp, sp, #{emit_int mh}\n`; + if ml <> 0 then ` {emit_string instr} sp, sp, #{emit_int ml}\n`; + if n <> 0 then cfi_adjust_cfa_offset (-n) + +(* Deallocate the stack frame and reload the return address + before a return or tail call *) + +let output_epilogue f = + let n = frame_size() in + if !contains_calls then + ` ldr x30, [sp, #{emit_int (n-8)}]\n`; + if n > 0 then + emit_stack_adjustment n; + f(); + (* reset CFA back because function body may continue *) + if n > 0 then cfi_adjust_cfa_offset n + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Pending floating-point literals *) +let float_literals = ref ([] : (int64 * label) list) + +(* Label a floating-point literal *) +let float_literal f = + try + List.assoc f !float_literals + with Not_found -> + let lbl = new_label() in + float_literals := (f, lbl) :: !float_literals; + lbl + +(* Emit all pending literals *) +let emit_literals() = + if !float_literals <> [] then begin + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}:`; emit_float64_directive ".quad" f) + !float_literals; + float_literals := [] + end + +(* Emit code to load the address of a symbol *) + +let emit_load_symbol_addr dst s = + if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin + ` adrp {emit_reg dst}, {emit_symbol s}\n`; + ` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n` + end else begin + ` adrp {emit_reg dst}, :got:{emit_symbol s}\n`; + ` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n` + end + +(* Output the assembly code for an instruction *) + +let emit_instr i = + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + | {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fmov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Stack _} -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack _}, {loc = Reg _} -> + ` ldr {emit_reg dst}, {emit_stack src}\n` + | _ -> + assert false + end + | Lop(Iconst_int n | Iconst_blockheader n) -> + emit_intconst i.res.(0) n + | Lop(Iconst_float f) -> + let b = Int64.bits_of_float f in + if b = 0L then + ` fmov {emit_reg i.res.(0)}, xzr\n` + else if is_immediate_float b then + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n` + else begin + let lbl = float_literal b in + ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; + ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` + end + | Lop(Iconst_symbol s) -> + emit_load_symbol_addr i.res.(0) s + | Lop(Icall_ind) -> + ` blr {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Icall_imm s) -> + ` bl {emit_symbol s}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Itailcall_ind) -> + output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` b {emit_label !tailrec_entry_point}\n` + else + output_epilogue (fun () -> ` b {emit_symbol s}\n`) + | Lop(Iextcall(s, false)) -> + ` bl {emit_symbol s}\n` + | Lop(Iextcall(s, true)) -> + emit_load_symbol_addr reg_x15 s; + ` bl {emit_symbol "caml_c_call"}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Istackoffset n) -> + assert (n mod 16 = 0); + emit_stack_adjustment (-n); + stack_offset := !stack_offset + n + | Lop(Iload(size, addr)) -> + let dst = i.res.(0) in + let base = + match addr with + | Iindexed ofs -> i.arg.(0) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned -> + ` ldrb {emit_wreg dst}, {emit_addressing addr base}\n` + | Byte_signed -> + ` ldrsb {emit_reg dst}, {emit_addressing addr base}\n` + | Sixteen_unsigned -> + ` ldrh {emit_wreg dst}, {emit_addressing addr base}\n` + | Sixteen_signed -> + ` ldrsh {emit_reg dst}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned -> + ` ldr {emit_wreg dst}, {emit_addressing addr base}\n` + | Thirtytwo_signed -> + ` ldrsw {emit_reg dst}, {emit_addressing addr base}\n` + | Single -> + ` ldr s7, {emit_addressing addr base}\n`; + ` fcvt {emit_reg dst}, s7\n` + | Word | Double | Double_u -> + ` ldr {emit_reg dst}, {emit_addressing addr base}\n` + end + | Lop(Istore(size, addr, _)) -> + let src = i.arg.(0) in + let base = + match addr with + | Iindexed ofs -> i.arg.(1) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned | Byte_signed -> + ` strb {emit_wreg src}, {emit_addressing addr base}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` strh {emit_wreg src}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned | Thirtytwo_signed -> + ` str {emit_wreg src}, {emit_addressing addr base}\n` + | Single -> + ` fcvt s7, {emit_reg src}\n`; + ` str s7, {emit_addressing addr base}\n`; + | Word | Double | Double_u -> + ` str {emit_reg src}, {emit_addressing addr base}\n` + end + | Lop(Ialloc n) -> + let lbl_frame = record_frame_label i.live i.dbg in + if !fastcode_flag then begin + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + `{emit_label lbl_redo}:`; + ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; + ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; + ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; + ` b.lo {emit_label lbl_call_gc}\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` + | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` + | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` + | _ -> emit_intconst reg_x15 (Nativeint.of_int n); + ` bl {emit_symbol "caml_allocN"}\n` + end; + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Ispecific(Ishiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.cs {emit_label lbl}\n` + | Lop(Iintop Imod) -> + ` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop Imulh) -> + ` smulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n` + | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) -> + let instr = (match op with + | Ifloatofint -> "scvtf" + | Iintoffloat -> "fcvtzs" + | Iabsf -> "fabs" + | Inegf -> "fneg" + | Ispecific Isqrtf -> "fsqrt" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> + let instr = (match op with + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | Ispecific Inegmulf -> "fnmul" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> + let instr = (match op with + | Imuladdf -> "fmadd" + | Inegmuladdf -> "fnmadd" + | Imulsubf -> "fmsub" + | Inegmulsubf -> "fnmsub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific(Ishiftarith(op, shift))) -> + let instr = (match op with + Ishiftadd -> "add" + | Ishiftsub -> "sub") in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + if shift >= 0 + then `, lsl #{emit_int shift}\n` + else `, asr #{emit_int (-shift)}\n` + | Lop(Ispecific(Imuladd | Imulsub as op)) -> + let instr = (match op with + Imuladd -> "madd" + | Imulsub -> "msub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` + | Lop(Ispecific(Ibswap size)) -> + begin match size with + | 16 -> + ` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`; + ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #16\n` + | 32 -> + ` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n` + | 64 -> + ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | _ -> + assert false + end + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue (fun () -> ` ret\n`) + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + | Itruetest -> + ` cbnz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Ifalsetest -> + ` cbz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + let comp = (match (cmp, neg) with + | (Ceq, false) | (Cne, true) -> "eq" + | (Cne, false) | (Ceq, true) -> "ne" + | (Clt, false) -> "cc" + | (Clt, true) -> "cs" + | (Cle, false) -> "ls" + | (Cle, true) -> "hi" + | (Cgt, false) -> "gt" + | (Cgt, true) -> "le" + | (Cge, false) -> "ge" + | (Cge, true) -> "lt") in + ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.{emit_string comp} {emit_label lbl}\n` + | Ioddtest -> + ` tbnz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + | Ieventest -> + ` tbz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, #1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` b.lt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` b.eq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` b.gt {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:`; + for j = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(j)}\n` + done +(* Alternative: + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` add {emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:\n`; + for j = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n` + done +*) + | Lsetuptrap lbl -> + let lblnext = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lblnext}:\n` + | Lpushtrap -> + stack_offset := !stack_offset + 16; + ` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`; + ` str {emit_reg reg_tmp1}, [sp, #8]\n`; + cfi_adjust_cfa_offset 16; + ` mov {emit_reg reg_trap_ptr}, sp\n` + | Lpoptrap -> + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + cfi_adjust_cfa_offset (-16); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> + ` bl {emit_symbol "caml_raise_exn"}\n`; + `{record_frame Reg.Set.empty i.dbg}\n` + | false, _ + | true, Lambda.Raise_notrace -> + ` mov sp, {emit_reg reg_trap_ptr}\n`; + ` ldr {emit_reg reg_tmp1}, [sp, #8]\n`; + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + ` br {emit_reg reg_tmp1}\n` + end + +(* Emission of an instruction sequence *) + +let rec emit_all i = + if i.desc = Lend then () else (emit_instr i; emit_all i.next) + +(* Emission of the profiling prelude *) + +let emit_profile() = () (* TODO *) +(* + match Config.system with + "linux_eabi" | "linux_eabihf" -> + ` push \{lr}\n`; + ` {emit_call "__gnu_mcount_nc"}\n` + | _ -> () +*) + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + float_literals := []; + stack_offset := 0; + call_gc_sites := []; + bound_error_sites := []; + ` .text\n`; + ` .align 3\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc(); + if !Clflags.gprofile then emit_profile(); + let n = frame_size() in + if n > 0 then + emit_stack_adjustment (-n); + if !contains_calls then + ` str x30, [sp, #{emit_int (n-8)}]\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + List.iter emit_call_bound_error !bound_error_sites; + cfi_endproc(); + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; + emit_literals() + +(* Emission of data *) + +let emit_item = function + | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> `{emit_symbol s}:\n` + | Cdefine_label lbl -> `{emit_data_label lbl}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_nativeint n}\n` + | Cint n -> ` .quad {emit_nativeint n}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) + | Csymbol_address s -> ` .quad {emit_symbol s}\n` + | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` + | Cstring s -> emit_string_directive " .ascii " s + | Cskip n -> if n > 0 then ` .space {emit_int n}\n` + | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + ` .align 3\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + reset_debug_info(); + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly () = + let lbl_end = Compilenv.make_symbol (Some "code_end") in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + ` .data\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + emit_frames + { efa_label = (fun lbl -> + ` .type {emit_label lbl}, %function\n`; + ` .quad {emit_label lbl}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + ` .type {emit_symbol lbl}, %object\n`; + ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; + begin match Config.system with + | "linux" -> + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` + | _ -> () + end diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml new file mode 100644 index 00000000..0222b72a --- /dev/null +++ b/asmcomp/arm64/proc.ml @@ -0,0 +1,226 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Description of the ARM processor in 64-bit mode *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + x0 - x15 general purpose (caller-save) + x16, x17 temporaries (used by call veeners) + x18 platform register (reserved) + x19 - x25 general purpose (callee-save) + x26 trap pointer + x27 alloc pointer + x28 alloc limit + x29 frame pointer + x30 return address + sp / xzr stack pointer / zero register + Floating-point register map: + d0 - d7 general purpose (caller-save) + d8 - d15 general purpose (callee-save) + d16 - d31 generat purpose (caller-save) +*) + +let int_reg_name = + [| "x0"; "x1"; "x2"; "x3"; "x4"; "x5"; "x6"; "x7"; + "x8"; "x9"; "x10"; "x11"; "x12"; "x13"; "x14"; "x15"; + "x19"; "x20"; "x21"; "x22"; "x23"; "x24"; "x25"; + "x26"; "x27"; "x28"; "x16"; "x17" |] + +let float_reg_name = + [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; + "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; + "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; + "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + | (Int | Addr) -> 0 + | Float -> 1 + +let num_available_registers = + [| 23; 32 |] (* first 23 int regs allocatable; all float regs allocatable *) + +let first_available_register = + [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.make 28 Reg.dummy in + for i = 0 to 27 do + v.(i) <- Reg.at_location Int (Reg i) + done; + v + +let hard_float_reg = + let v = Array.make 32 Reg.dummy in + for i = 0 to 31 do + v.(i) <- Reg.at_location Float (Reg(100 + i)) + done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let reg_x15 = phys_reg 15 +let reg_d7 = phys_reg 107 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack arg = + let loc = Array.make (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +(* OCaml calling convention: + first integer args in r0...r15 + first float args in d0...d15 + remaining args on stack. + Return values in r0...r15 or d0...d15. *) + +let loc_arguments arg = + calling_conventions 0 15 100 115 outgoing arg +let loc_parameters arg = + let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc +let loc_results res = + let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc + +(* C calling convention: + first integer args in r0...r7 + first float args in d0...d7 + remaining args on stack. + Return values in r0...r1 or d0. *) + +let loc_external_arguments arg = + calling_conventions 0 7 100 107 outgoing arg +let loc_external_results res = + let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 + +(* Volatile registers: none *) + +let regs_are_volatile rs = false + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + (* x19-x28, d8-d15 preserved *) + Array.of_list (List.map phys_reg + [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15; + 100;101;102;103;104;105;106;107; + 116;117;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131]) + +let destroyed_at_oper = function + | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> + all_phys_regs + | Iop(Iextcall(_, false)) -> + destroyed_at_c_call + | Iop(Ialloc _) -> + [| reg_x15 |] + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> + [| reg_d7 |] (* d7 / s7 destroyed *) + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + | Iextcall(_, _) -> 8 + | Ialloc _ -> 25 + | _ -> 26 + +let max_register_pressure = function + | Iextcall(_, _) -> [| 10; 8 |] + | Ialloc _ -> [| 25; 32 |] + | Iintoffloat | Ifloatofint + | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] + | _ -> [| 26; 32 |] + +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + + +let init () = () diff --git a/asmcomp/arm64/reload.ml b/asmcomp/arm64/reload.ml new file mode 100644 index 00000000..ff9214ef --- /dev/null +++ b/asmcomp/arm64/reload.ml @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Reloading for the ARM 64 bits *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff --git a/asmcomp/arm64/scheduling.ml b/asmcomp/arm64/scheduling.ml new file mode 100644 index 00000000..cc244be7 --- /dev/null +++ b/asmcomp/arm64/scheduling.ml @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +let _ = let module M = Schedgen in () (* to create a dependency *) + +(* Scheduling is turned off because the processor schedules dynamically + much better than what we could do. *) + +let fundecl f = f diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml new file mode 100644 index 00000000..e7ded8fb --- /dev/null +++ b/asmcomp/arm64/selection.ml @@ -0,0 +1,243 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Instruction selection for the ARM processor *) + +open Arch +open Cmm +open Mach + +let is_offset chunk n = + (n >= -256 && n <= 255) (* 9 bits signed unscaled *) +|| (n >= 0 && + match chunk with (* 12 bits unsigned, scaled by chunk size *) + | Byte_unsigned | Byte_signed -> + n < 0x1000 + | Sixteen_unsigned | Sixteen_signed -> + n land 1 = 0 && n lsr 1 < 0x1000 + | Thirtytwo_unsigned | Thirtytwo_signed | Single -> + n land 3 = 0 && n lsr 2 < 0x1000 + | Word | Double | Double_u -> + n land 7 = 0 && n lsr 3 < 0x1000) + +(* An automaton to recognize ( 0+1+0* | 1+0+1* ) + + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [1] --1--> [2] --0--> [3] + / + [0] + \ + -1--> [4] --0--> [5] --1--> [6] + / \ / \ / \ + \ / \ / \ / + 1 0 1 + +The accepting states are 2, 3, 5 and 6. *) + +let auto_table = [| (* accepting?, next on 0, next on 1 *) + (* state 0 *) (false, 1, 4); + (* state 1 *) (false, 1, 2); + (* state 2 *) (true, 3, 2); + (* state 3 *) (true, 3, 7); + (* state 4 *) (false, 5, 4); + (* state 5 *) (true, 5, 6); + (* state 6 *) (true, 7, 6); + (* state 7 *) (false, 7, 7) (* error state *) +|] + +let rec run_automata nbits state input = + let (acc, next0, next1) = auto_table.(state) in + if nbits <= 0 + then acc + else run_automata (nbits - 1) + (if input land 1 = 0 then next0 else next1) + (input asr 1) + +(* We are very conservative wrt what ARM64 supports: we don't support + repetitions of a 000111000 or 1110000111 pattern, just a single + pattern of this kind. *) + +let is_logical_immediate n = + n <> 0 && n <> -1 && run_automata 64 0 n + +let is_intconst = function + Cconst_int _ -> true + | _ -> false + +let inline_ops = + [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; + "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] + +let use_direct_addressing symb = + (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb + +(* Instruction selection *) + +class selector = object(self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = + let mn = -n in + n land 0xFFF = n || n land 0xFFF_000 = n + || mn land 0xFFF = mn || mn land 0xFFF_000 = mn + +method! is_simple_expr = function + (* inlined floating-point ops are simple if their arguments are *) + | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e + +method select_addressing chunk = function + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) + when use_direct_addressing s -> + (Ibased(s, n), Ctuple []) + | Cop(Cadda, [arg; Cconst_int n]) + when is_offset chunk n -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) + when is_offset chunk n -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | Cconst_symbol s + when use_direct_addressing s -> + (Ibased(s, 0), Ctuple []) + | arg -> + (Iindexed 0, arg) + +method! select_operation op args = + match op with + (* Integer addition *) + | Caddi | Cadda -> + begin match args with + (* Add immediate *) + | [arg; Cconst_int n] | [Cconst_int n; arg] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), + [arg]) + (* Shift-add *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2]) + | [Cop(Clsl, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1]) + | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1]) + (* Multiply-add *) + | [arg1; Cop(Cmuli, args2)] | [Cop(Cmuli, args2); arg1] -> + begin match self#select_operation Cmuli args2 with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imuladd, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args + end + | _ -> + super#select_operation op args + end + (* Integer subtraction *) + | Csubi | Csuba -> + begin match args with + (* Sub immediate *) + | [arg; Cconst_int n] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)), + [arg]) + (* Shift-sub *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2]) + (* Multiply-sub *) + | [arg1; Cop(Cmuli, args2)] -> + begin match self#select_operation Cmuli args2 with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imulsub, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args + end + | _ -> + super#select_operation op args + end + (* Checkbounds *) + | Ccheckbound _ -> + begin match args with + | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | _ -> + super#select_operation op args + end + (* Integer multiplication *) + (* ARM does not support immediate operands for multiplication *) + | Cmuli -> + (Iintop Imul, args) + | Cmulhi -> + (Iintop Imulh, args) + (* Bitwise logical operations have a different range of immediate + operands than the other instructions *) + | Cand -> self#select_logical Iand args + | Cor -> self#select_logical Ior args + | Cxor -> self#select_logical Ixor args + (* Recognize floating-point negate and multiply *) + | Cnegf -> + begin match args with + | [Cop(Cmulf, args)] -> (Ispecific Inegmulf, args) + | _ -> super#select_operation op args + end + (* Recognize floating-point multiply and add/sub *) + | Caddf -> + begin match args with + | [arg; Cop(Cmulf, args)] | [Cop(Cmulf, args); arg] -> + (Ispecific Imuladdf, arg :: args) + | _ -> + super#select_operation op args + end + | Csubf -> + begin match args with + | [arg; Cop(Cmulf, args)] -> + (Ispecific Imulsubf, arg :: args) + | [Cop(Cmulf, args); arg] -> + (Ispecific Inegmulsubf, arg :: args) + | _ -> + super#select_operation op args + end + (* Recognize floating-point square root *) + | Cextcall("sqrt", _, _, _) -> + (Ispecific Isqrtf, args) + (* Recognize bswap instructions *) + | Cextcall("caml_bswap16_direct", _, _, _) -> + (Ispecific(Ibswap 16), args) + | Cextcall("caml_int32_direct_bswap", _, _, _) -> + (Ispecific(Ibswap 32), args) + | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"), + _, _, _) -> + (Ispecific (Ibswap 64), args) + (* Other operations are regular *) + | _ -> + super#select_operation op args + +method select_logical op = function + | [arg; Cconst_int n] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 40f7dafb..311bb029 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -64,7 +64,10 @@ let compile_fundecl (ppf : formatter) fd_cmm = ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ CSE.fundecl + ++ pass_dump_if ppf dump_cse "After CSE" ++ liveness ppf + ++ Deadcode.fundecl ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl ++ liveness ppf @@ -140,3 +143,10 @@ let report_error ppf = function | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 140791f2..968e1de7 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -69,3 +69,10 @@ let report_error ppf = function fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f6a85a94..153da7ca 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -33,31 +33,37 @@ exception Error of error (* Consistency check between interfaces and implementations *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let crc_implementations = Consistbl.create () -let extra_implementations = ref ([] : string list) +let implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter - (fun (name, crc) -> - if name = unit.ui_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = unit.ui_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter - (fun (name, crc) -> - if crc <> cmx_not_found_crc then - Consistbl.check crc_implementations name crc file_name - else if List.mem name !cmx_required then - raise(Error(Missing_cmx(file_name, name))) - else - extra_implementations := name :: !extra_implementations) + (fun (name, crco) -> + implementations := name :: !implementations; + match crco with + None -> + if List.mem name !cmx_required then + raise(Error(Missing_cmx(file_name, name))) + | Some crc -> + Consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -67,6 +73,7 @@ let check_consistency file_name unit crc = raise (Error(Multiple_definition(unit.ui_name, file_name, source))) with Not_found -> () end; + implementations := unit.ui_name :: !implementations; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; @@ -74,13 +81,9 @@ let check_consistency file_name unit crc = cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = - List.fold_left - (fun ncl n -> - if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) - (Consistbl.extract crc_implementations) - !extra_implementations + Consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -206,18 +209,22 @@ let make_startup_file ppf filename units_list = compile_phrase (Cmmgen.entry_point name_list); let units = List.map (fun (info,_,_) -> info) units_list in List.iter compile_phrase (Cmmgen.generic_functions false units); - Array.iter - (fun name -> compile_phrase (Cmmgen.predef_exception name)) + Array.iteri + (fun i name -> compile_phrase (Cmmgen.predef_exception i name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, - crc, - unit.ui_defines) - with Not_found -> assert false) + let intf_crc = + try + match List.assoc unit.ui_name unit.ui_imports_cmi with + None -> assert false + | Some crc -> crc + with Not_found -> assert false + in + (unit.ui_name, intf_crc, crc, unit.ui_defines)) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); @@ -390,3 +397,18 @@ let report_error ppf = function Location.print_filename filename name Location.print_filename filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + Consistbl.clear crc_interfaces; + Consistbl.clear crc_implementations; + implementations_defined := []; + cmx_required := []; + interfaces := []; + implementations := [] diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 1cf9e302..60a2111e 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -20,9 +20,10 @@ val link_shared: formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit +val reset : unit -> unit val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list -val extract_crc_implementations: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list +val extract_crc_implementations: unit -> (string * Digest.t option) list type error = File_not_found of string diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 1a4fe902..d900df1e 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -130,7 +130,7 @@ let build_package_cmx members cmxfile = List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_symbol]; ui_imports_cmi = - (ui.ui_name, Env.crc_of_unit ui.ui_name) :: + (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) :: filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); @@ -161,7 +161,7 @@ let package_object_files ppf files targetcmx (* The entry point *) -let package_files ppf files targetcmx = +let package_files ppf initial_env files targetcmx = let files = List.map (fun f -> @@ -177,7 +177,8 @@ let package_files ppf files targetcmx = (* Set the name of the current compunit *) Compilenv.reset ?packname:!Clflags.for_package targetname; try - let coercion = Typemod.package_units files targetcmi targetname in + let coercion = + Typemod.package_units initial_env files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion with x -> remove_file targetcmx; remove_file targetobj; @@ -204,3 +205,10 @@ let report_error ppf = function fprintf ppf "Error while assembling %s" file | Linking_error -> fprintf ppf "Error during partial linking" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index 65272b7e..4d47f5c2 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -13,7 +13,7 @@ (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Illegal_renaming of string * string * string diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index dd53020d..ed96f218 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -18,9 +18,23 @@ open Lambda type function_label = string +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -59,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +84,67 @@ type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants. We must not use Pervasives.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | _, _ -> rank_structured_constant c1 - rank_structured_constant c2 + (* no overflow possible here *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 737965db..fc7a14d1 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -18,9 +18,23 @@ open Lambda type function_label = string +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -59,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +84,12 @@ type value_approximation = Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index dc4c73ad..249e67c4 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -19,6 +19,14 @@ open Lambda open Switch open Clambda +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -48,7 +56,7 @@ let getglobal id = let occurs_var var u = let rec occurs = function Uvar v -> v = var - | Uconst (cst,_) -> false + | Uconst _ -> false | Udirect_apply(lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos @@ -60,6 +68,10 @@ let occurs_var var u = | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -81,6 +93,52 @@ let occurs_var var u = true in occurs u +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper fun_id kind params body = + let rec aux map = function + | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; + + let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun p -> Lvar (map_param p)) params in + let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in + + let inner_params = List.map map_param params in + let new_ids = List.map Ident.rename inner_params in + let subst = List.fold_left2 + (fun s id new_id -> + Ident.add id (Lvar new_id) s) + Ident.empty inner_params new_ids + in + let body = Lambda.subst_lambda subst body in + let inner_fun = Lfunction(Curried, new_ids, body) in + (wrapper_body, (inner_id, inner_fun)) + in + try + let wrapper_body, inner = aux [] body in + [(fun_id, Lfunction(kind, params, wrapper_body)); inner] + with Exit -> + [(fun_id, Lfunction(kind, params, body))] + + (* Determine whether the estimated size of a clambda term is below some threshold *) @@ -96,7 +154,7 @@ let prim_size prim args = | Psetfloatfield f -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args - | Praise -> 4 + | Praise _ -> 4 | Pstringlength -> 5 | Pstringrefs | Pstringsets -> 6 | Pmakearray kind -> 5 + List.length args @@ -118,14 +176,7 @@ let lambda_smaller lam threshold = if !size > threshold then raise Exit; match lam with Uvar v -> () - | Uconst( - (Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _) | - Const_pointer _), _) -> incr size -(* Structured Constants are now emitted during closure conversion. *) - | Uconst (_, Some _) -> incr size - | Uconst _ -> - raise Exit (* avoid duplication of structured constants *) + | Uconst _ -> incr size | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> @@ -147,6 +198,15 @@ let lambda_smaller lam threshold = lambda_size lam; lambda_array_size cases.us_actions_consts ; lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + Misc.may lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -180,17 +240,20 @@ let rec is_pure_clambda = function Uvar v -> true | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false -(* Simplify primitive operations on integers *) +(* Simplify primitive operations on known arguments *) -let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) -let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) +let make_const c = (Uconst c, Value_const c) +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c)) +let make_const_int n = make_const (Uconst_int n) +let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp (x: int) (y: int) = +let make_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y @@ -199,75 +262,258 @@ let make_comparison cmp (x: int) (y: int) = | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) + +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) -let simplif_prim_pure p (args, approxs) dbg = +let simplif_arith_prim_pure fpc p (args, approxs) dbg = + let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with - [Value_integer x] -> + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> begin match p with - Pidentity -> make_const_int x - | Pnegint -> make_const_int (-x) - | Pbswap16 -> - make_const_int (((x land 0xff) lsl 8) lor - ((x land 0xff00) lsr 8)) - | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default end - | [Value_integer x; Value_integer y] -> + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> begin match p with - Paddint -> make_const_int(x + y) - | Psubint -> make_const_int(x - y) - | Pmulint -> make_const_int(x * y) - | Pdivint when y <> 0 -> make_const_int(x / y) - | Pmodint when y <> 0 -> make_const_int(x mod y) - | Pandint -> make_const_int(x land y) - | Porint -> make_const_int(x lor y) - | Pxorint -> make_const_int(x lxor y) - | Plslint -> make_const_int(x lsl y) - | Plsrint -> make_const_int(x lsr y) - | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x] -> + (* float *) + | [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc -> begin match p with - Pidentity -> make_const_ptr x - | Pnot -> make_const_bool(x = 0) - | Pisint -> make_const_bool true - | Pctconst c -> - begin - match c with - | Big_endian -> make_const_bool Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - end - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default end - | [Value_constptr x; Value_constptr y] -> + (* float, float *) + | [Value_const(Uconst_ref(_, Uconst_float n1)); + Value_const(Uconst_ref(_, Uconst_float n2))] when fpc -> begin match p with - Psequand -> make_const_bool(x <> 0 && y <> 0) - | Psequor -> make_const_bool(x <> 0 || y <> 0) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x; Value_integer y] -> + (* nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default + end + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_ref(_, Uconst_nativeint n2))] -> + begin match p with + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_ref(_, Uconst_int32 n2))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2) + | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_ref(_, Uconst_int64 n2))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2) + | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | _ -> default end - | [Value_integer x; Value_constptr y] -> + (* int64, int *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_int n2)] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) + | _ -> + default + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Uconst_block(_, l))) when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure fpc p (args, approxs) dbg = + match p, args, approxs with + (* Block construction *) + | Pmakeblock(tag, Immutable), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + (* Field access *) + | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ] + when n < List.length l -> + make_const (List.nth l n) + | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] -> + make_const_int (String.length s) + (* Identity *) + | Pidentity, [arg1], [app1] -> + (arg1, app1) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false | _ -> (Uprim(p, args, dbg), Value_unknown) end + (* Compile-time constants *) + | Pctconst c, _, _ -> + begin match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + end + (* Catch-all *) | _ -> - (Uprim(p, args, dbg), Value_unknown) + simplif_arith_prim_pure fpc p (args, approxs) dbg -let simplif_prim p (args, approxs as args_approxs) dbg = +let simplif_prim fpc p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs dbg - else (Uprim(p, args, dbg), Value_unknown) + then simplif_prim_pure fpc p args_approxs dbg + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | Pmakeblock(_, Immutable) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -279,20 +525,19 @@ let simplif_prim p (args, approxs as args_approxs) dbg = over functions. *) let approx_ulam = function - Uconst(Const_base(Const_int n),_) -> Value_integer n - | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) - | Uconst(Const_pointer n,_) -> Value_constptr n + Uconst c -> Value_const c | _ -> Value_unknown -let rec substitute sb ulam = +let rec substitute fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute sb) args, dbg) + Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) + Ugeneric_apply(substitute fpc sb fn, + List.map (substitute fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -302,11 +547,12 @@ let rec substitute sb ulam = - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) + Uclosure(defs, List.map (substitute fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs) | Ulet(id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + Ulet(id', substitute fpc sb u1, + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -315,86 +561,102 @@ let rec substitute sb ulam = (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( - List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, - substitute sb' body) + List.map + (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + bindings1, + substitute fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in + let sargs = + List.map (substitute fpc sb) args in + let (res, _) = + simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute sb arg, + Uswitch(substitute fpc sb arg, { sw with us_actions_consts = - Array.map (substitute sb) sw.us_actions_consts; + Array.map (substitute fpc sb) sw.us_actions_consts; us_actions_blocks = - Array.map (substitute sb) sw.us_actions_blocks; + Array.map (substitute fpc sb) sw.us_actions_blocks; }) + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (substitute fpc sb arg, + List.map (fun (s,act) -> s,substitute fpc sb act) sw, + Misc.may_map (substitute fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute sb) args) + Ustaticfail (nfail, List.map (substitute fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> - Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + Ucatch(nfail, ids, substitute fpc sb u1, substitute fpc sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute fpc sb u1, id', + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute sb u1 with - Uconst(Const_pointer n, _) -> - if n <> 0 then substitute sb u2 else substitute sb u3 + begin match substitute fpc sb u1 with + Uconst (Uconst_ptr n) -> + if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3 + | Uprim(Pmakeblock _, _, _) -> + substitute fpc sb u2 | su1 -> - Uifthenelse(su1, substitute sb u2, substitute sb u3) + Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3) end - | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) - | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Usequence(u1, u2) -> + Usequence(substitute fpc sb u1, substitute fpc sb u2) + | Uwhile(u1, u2) -> + Uwhile(substitute fpc sb u1, substitute fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute sb u1, substitute sb u2, dir, - substitute (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir, + substitute fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute sb u) + Uassign(id', substitute fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, - dbg) + Usend(k, substitute fpc sb u1, substitute fpc sb u2, + List.map (substitute fpc sb) ul, dbg) (* Perform an inline expansion *) let is_simple_argument = function - Uvar _ -> true - | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> - true - | Uconst(Const_pointer _, _) -> true + | Uvar _ | Uconst _ -> true | _ -> false let no_effects = function - Uclosure _ -> true - | Uconst(Const_base(Const_string _),_) -> true + | Uclosure _ -> true | u -> is_simple_argument u -let rec bind_params_rec subst params args body = +let rec bind_params_rec fpc subst params args body = match (params, args) with - ([], []) -> substitute subst body + ([], []) -> substitute fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec (Tbl.add p1 a1 subst) pl al body + bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in + let u1, u2 = + match Ident.name p1, a1 with + | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) -> + a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg) + | _ -> + a1, Uvar p1' + in let body' = - bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in - if occurs_var p1 body then Ulet(p1', a1, body') + bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in + if occurs_var p1 body then Ulet(p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params params args body = +let bind_params fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -403,7 +665,7 @@ let rec is_pure = function Lvar v -> true | Lconst cst -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false | Lprim(p, args) -> List.for_all is_pure args | Levent(lam, ev) -> is_pure lam @@ -416,8 +678,10 @@ let direct_apply fundesc funct ufunct uargs = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) - | Some(params, body) -> bind_params params app_args body in + | None -> + Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) + | Some(params, body) -> + bind_params fundesc.fun_float_const_prop params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the @@ -432,7 +696,8 @@ let direct_apply fundesc funct ufunct uargs = let strengthen_approx appl approx = match approx_ulam appl with - (Value_integer _ | Value_constptr _) as intapprox -> intapprox + (Value_const _) as intapprox -> + intapprox | _ -> approx (* If a term has approximation Value_integer or Value_constptr and is pure, @@ -440,8 +705,16 @@ let strengthen_approx appl approx = let check_constant_result lam ulam approx = match approx with - Value_integer n when is_pure lam -> make_const_int n - | Value_constptr n when is_pure lam -> make_const_ptr n + Value_const c when is_pure lam -> make_const c + | Value_global_field (id, i) when is_pure lam -> + begin match ulam with + | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) + in + Uprim(Pfield i, [glb], Debuginfo.none), approx + end | _ -> (ulam, approx) (* Evaluate an expression with known value for its side effects only, @@ -473,8 +746,8 @@ let rec add_debug_info ev u = args2, Debuginfo.from_call ev) | Ugeneric_apply(fn, args, dinfo) -> Ugeneric_apply(fn, args, Debuginfo.from_call ev) - | Uprim(Praise, args, dinfo) -> - Uprim(Praise, args, Debuginfo.from_call ev) + | Uprim(Praise k, args, dinfo) -> + Uprim(Praise k, args, Debuginfo.from_call ev) | Uprim(p, args, dinfo) -> Uprim(p, args, Debuginfo.from_call ev) | Usend(kind, u1, u2, args, dinfo) -> @@ -492,13 +765,12 @@ let rec add_debug_info ev u = The closure environment [cenv] maps idents to [ulambda] terms. It is used to substitute environment accesses for free identifiers. *) +exception NotClosed + let close_approx_var fenv cenv id = let approx = try Tbl.find id fenv with Not_found -> Value_unknown in match approx with - Value_integer n -> - make_const_int n - | Value_constptr n -> - make_const_ptr n + Value_const c -> make_const c | approx -> let subst = try Tbl.find id cenv with Not_found -> Uvar id in (subst, approx) @@ -510,14 +782,33 @@ let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id | Lconst cst -> - begin match cst with - Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) - | Const_base(Const_char c) -> (Uconst (cst,None), - Value_integer(Char.code c)) - | Const_pointer n -> (Uconst (cst, None), Value_constptr n) - | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), - Value_unknown) - end + let str ?(shared = true) cst = + let name = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array (List.map float_of_string sl)) + | Const_immstring s -> + str (Uconst_string s) + | Const_base (Const_string (s, _)) -> + (* strings (even literal ones) are mutable! *) + (* of course, the empty string is really immutable *) + str ~shared:false(*(String.length s = 0)*) (Uconst_string s) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) + | Const_base(Const_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct @@ -581,7 +872,7 @@ let rec close fenv cenv = function (Variable, _) -> let (ubody, abody) = close fenv cenv body in (Ulet(id, ulam, ubody), abody) - | (_, (Value_integer _ | Value_constptr _)) + | (_, Value_const _) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> @@ -606,7 +897,7 @@ let rec close fenv cenv = function (fun (id, pos, approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute sb ubody), + (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -614,7 +905,7 @@ let rec close fenv cenv = function [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close fenv cenv lam in + let (ulam, approx) = close_named fenv cenv id lam in ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in @@ -627,45 +918,67 @@ let rec close fenv cenv = function check_constant_result lam (getglobal id) (Compilenv.global_approx id) - | Lprim(Pmakeblock(tag, mut) as prim, lams) -> - let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams, Debuginfo.none), - begin match mut with - Immutable -> Value_tuple(Array.of_list approxs) - | Mutable -> Value_unknown - end) | Lprim(Pfield n, [lam]) -> let (ulam, approx) = close fenv cenv lam in - let fieldapprox = - match approx with - Value_tuple a when n < Array.length a -> a.(n) - | _ -> Value_unknown in check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) - fieldapprox + (field_approx n approx) | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in - (!global_approx).(n) <- approx; + if approx <> Value_unknown then + (!global_approx).(n) <- approx; (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), Value_unknown) - | Lprim(Praise, [Levent(arg, ev)]) -> + | Lprim(Praise k, [Levent(arg, ev)]) -> let (ulam, approx) = close fenv cenv arg in - (Uprim(Praise, [ulam], Debuginfo.from_raise ev), + (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none + simplif_prim !Clflags.float_const_prop + p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> + let fn fail = + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions, fconst = + close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}) in + (fconst (fblock ulam),Value_unknown) in (* NB: failaction might get copied, thus it should be some Lstaticraise *) - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction - and block_index, block_actions = - close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in - (Uswitch(uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}), - Value_unknown) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close fenv cenv lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end + | Lstringswitch(arg,sw,d) -> + let uarg,_ = close fenv cenv arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close fenv cenv act in + s,uact) + sw in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close fenv cenv d in + ud) d in + Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lstaticcatch(body, (i, vars), handler) -> @@ -678,7 +991,7 @@ let rec close fenv cenv = function (Utrywith(ubody, id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with - (uarg, Value_constptr n) -> + (uarg, Value_const (Uconst_ptr n)) -> sequence_constant_expr arg uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> @@ -730,6 +1043,17 @@ and close_named fenv cenv id = function (* Build a shared closure for a set of mutually recursive functions *) and close_functions fenv cenv fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction(kind, params, body)) -> + split_default_wrapper id kind params body + | _ -> assert false + ) + fun_defs) + in + (* Update and check nesting depth *) incr function_nesting_depth; let initially_closed = @@ -750,7 +1074,8 @@ and close_functions fenv cenv fun_defs = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in @@ -783,31 +1108,52 @@ and close_functions fenv cenv fun_defs = build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, arity, body) pos env -> + (fun (id, params, body, fundesc) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in - if !useless_env && occurs_var env_param ubody then useless_env := false; + if !useless_env && occurs_var env_param ubody then raise NotClosed; let fun_params = if !useless_env then params else params @ [env_param] in - ({ label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = fun_params; - body = ubody; - dbg }, - (id, env_pos, Value_closure(fundesc, approx))) in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + if lambda_smaller ubody + (!Clflags.inline_threshold + n) + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = if initially_closed then begin - let cl = List.map2 clos_fundef uncurried_defs clos_offsets in + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> (* If the hypothesis that the environment parameters are useless has been invalidated, then set [fun_closed] to false in all descriptions and recompile *) - if !useless_env then cl else begin + Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) + (fun (id, params, body, fundesc) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) uncurried_defs; + useless_env := false; List.map2 clos_fundef uncurried_defs clos_offsets - end end else (* Excessive closure nesting: assume environment parameter is used *) List.map2 clos_fundef uncurried_defs clos_offsets @@ -817,31 +1163,27 @@ and close_functions fenv cenv fun_defs = (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) (* Same, for one non-recursive function *) and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([f], _) as clos), - [_, _, (Value_closure(fundesc, _) as approx)]) -> - (* See if the function can be inlined *) - if lambda_smaller f.body - (!Clflags.inline_threshold + List.length f.params) - then fundesc.fun_inline <- Some(f.params, f.body); - (clos, approx) - | _ -> fatal_error "Closure.close_one_function" + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" (* Close a switch *) -and close_switch fenv cenv cases num_keys default = - let index = Array.create num_keys 0 - and store = mk_store Lambda.same in +and close_switch arg fenv cenv cases num_keys default = + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in (* First default case *) begin match default with - | Some def when List.length cases < num_keys -> - ignore (store.act_store def) + | Some def when ncases < num_keys -> + assert (store.act_store def = 0) | _ -> () end ; (* Then all other cases *) @@ -849,24 +1191,108 @@ and close_switch fenv cenv cases num_keys default = (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; - (* Compile action *) + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) let actions = Array.map - (fun lam -> - let ulam,_ = close fenv cenv lam in - ulam) - (store.act_get ()) in + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close fenv cenv lam in + ulam + | Shared lam -> + let ulam,_ = close fenv cenv lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in match actions with - | [| |] -> [| |], [| |] (* May happen when default is None *) - | _ -> index, actions + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs + +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, c) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_, u1, u2) -> ulam u1; ulam u2 + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + Misc.may ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + in + approx a + +let reset () = + global_approx := [||]; + function_nesting_depth := 0 (* The entry point *) let intro size lam = - function_nesting_depth := 0; - global_approx := Array.create size Value_unknown; + reset (); + let id = Compilenv.make_symbol None in + global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in + if !Clflags.opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli index e7bccbca..2db6e163 100644 --- a/asmcomp/closure.mli +++ b/asmcomp/closure.mli @@ -13,3 +13,4 @@ (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda +val reset : unit -> unit diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 941b0142..67ee3445 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -70,7 +70,7 @@ type operation = | Cload of memory_chunk | Calloc | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba @@ -79,16 +79,17 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t + | Craise of Lambda.raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -117,8 +118,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 202b6aec..97b8d409 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -56,7 +56,7 @@ type operation = | Cload of memory_chunk | Calloc | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba @@ -65,16 +65,17 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t + | Craise of Lambda.raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -103,8 +104,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 23d47983..1f640b9b 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -27,24 +27,33 @@ open Cmx_format let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. byterun/gc.h *) + (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) -let float_tag = Cconst_int Obj.double_tag let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) -let closure_header sz = block_header Obj.closure_tag sz +(* Static data corresponding to "value"s must be marked black in case we are + in no-naked-pointers mode. See [caml_darken] and the code below that emits + structured constants and static module definitions. *) +let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black +let white_closure_header sz = block_header Obj.closure_tag sz +let black_closure_header sz = black_block_header Obj.closure_tag sz let infix_header ofs = block_header Obj.infix_tag ofs let float_header = block_header Obj.double_tag (size_float / size_addr) let floatarray_header len = @@ -55,14 +64,14 @@ let boxedint32_header = block_header Obj.custom_tag 2 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 -let alloc_block_header tag sz = Cconst_natint(block_header tag sz) -let alloc_float_header = Cconst_natint(float_header) -let alloc_floatarray_header len = Cconst_natint(floatarray_header len) -let alloc_closure_header sz = Cconst_natint(closure_header sz) -let alloc_infix_header ofs = Cconst_natint(infix_header ofs) -let alloc_boxedint32_header = Cconst_natint(boxedint32_header) -let alloc_boxedint64_header = Cconst_natint(boxedint64_header) -let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header) +let alloc_block_header tag sz = Cconst_blockheader(block_header tag sz) +let alloc_float_header = Cconst_blockheader(float_header) +let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len) +let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz) +let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs) +let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header) +let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header) +let alloc_boxedintnat_header = Cconst_blockheader(boxedintnat_header) (* Integers *) @@ -75,10 +84,14 @@ let int_const n = else Cconst_natint (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) -let add_const c n = +let rec add_const c n = if n = 0 then c else match c with | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) + | Cop(Csubi, [Cconst_int x; c]) when no_overflow_add n x -> + Cop(Csubi, [Cconst_int (n + x); c]) + | Cop(Csubi, [c; Cconst_int x]) when no_overflow_sub n x -> + add_const c (n - x) | c -> Cop(Caddi, [c; Cconst_int n]) let incr_int = function @@ -121,31 +134,16 @@ let sub_int c1 c2 = let mul_int c1 c2 = match (c1, c2) with - (Cconst_int 0, _) -> c1 - | (Cconst_int 1, _) -> c2 - | (_, Cconst_int 0) -> c2 - | (_, Cconst_int 1) -> c1 - | (_, _) -> Cop(Cmuli, [c1; c2]) - -let tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) - -let force_tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) - -let untag_int = function - Cconst_int n -> Cconst_int(n asr 1) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c - | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Casr, [c; Cconst_int (n+1)]) - | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Clsr, [c; Cconst_int (n+1)]) - | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) - | c -> Cop(Casr, [c; Cconst_int 1]) + (c, Cconst_int 0) | (Cconst_int 0, c) -> + Cconst_int 0 + | (c, Cconst_int 1) | (Cconst_int 1, c) -> + c + | (c, Cconst_int(-1)) | (Cconst_int(-1), c) -> + sub_int (Cconst_int 0) c + | (c, Cconst_int n) | (Cconst_int n, c) when n = 1 lsl Misc.log2 n-> + Cop(Clsl, [c; Cconst_int(Misc.log2 n)]) + | (c1, c2) -> + Cop(Cmuli, [c1; c2]) let lsl_int c1 c2 = match (c1, c2) with @@ -163,64 +161,251 @@ let ignore_low_bit_int = function let lsr_int c1 c2 = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Clsr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Clsr, [ignore_low_bit_int c1; c2]) | _ -> - Cop(Clsr, [c1; c2]) + Cop(Clsr, [c1; c2]) let asr_int c1 c2 = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Casr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Casr, [ignore_low_bit_int c1; c2]) | _ -> - Cop(Casr, [c1; c2]) + Cop(Casr, [c1; c2]) -(* Division or modulo on tagged integers. The overflow case min_int / -1 - cannot occur, but we must guard against division by zero. *) +let tag_int = function + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n]) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1]) + | c -> + incr_int (lsl_int c (Cconst_int 1)) -let is_different_from x = function - Cconst_int n -> n <> x - | Cconst_natint n -> n <> Nativeint.of_int x - | _ -> false +let force_tag_int = function + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n]) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1]) + | c -> + Cop(Cor, [lsl_int c (Cconst_int 1); Cconst_int 1]) -let safe_divmod op c1 c2 dbg = - if !Clflags.fast || is_different_from 0 c2 then - Cop(op, [c1; c2]) - else - bind "divisor" c2 (fun c2 -> - Cifthenelse(c2, - Cop(op, [c1; c2]), - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"]))) +let untag_int = function + Cconst_int n -> Cconst_int(n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Casr, [c; Cconst_int (n+1)]) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Clsr, [c; Cconst_int (n+1)]) + | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) + | c -> Cop(Casr, [c; Cconst_int 1]) + +(* Turning integer divisions into multiply-high then shift. + The [division_parameters] function is used in module Emit for + those target platforms that support this optimization. *) + +(* Unsigned comparison between native integers. *) + +let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int)) + +(* Unsigned division and modulus at type nativeint. + Algorithm: Hacker's Delight section 9.3 *) + +let udivmod n d = Nativeint.( + if d < 0n then + if ucompare n d < 0 then (0n, n) else (1n, sub n d) + else begin + let q = shift_left (div (shift_right_logical n 1) d) 1 in + let r = sub n (mul q d) in + if ucompare r d >= 0 then (succ q, sub r d) else (q, r) + end) + +(* Compute division parameters. + Algorithm: Hacker's Delight chapter 10, fig 10-1. *) + +let divimm_parameters d = Nativeint.( + assert (d > 0n); + let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *) + let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in + let rec loop p (q1, r1) (q2, r2) = + let p = p + 1 in + let q1 = shift_left q1 1 and r1 = shift_left r1 1 in + let (q1, r1) = + if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in + let q2 = shift_left q2 1 and r2 = shift_left r2 1 in + let (q2, r2) = + if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in + let delta = sub d r2 in + if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n) + then loop p (q1, r1) (q2, r2) + else (succ q2, p - size) + in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d)) + +(* The result [(m, p)] of [divimm_parameters d] satisfies the following + inequality: + + 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i) + + from which it follows that + + floor(n / d) = floor(n * m / 2^(wordsize+p)) + if 0 <= n < 2^(wordsize-1) + ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1 + if -2^(wordsize-1) <= n < 0 + + The correctness condition (i) above can be checked by the code below. + It was exhaustively tested for values of d from 2 to 10^9 in the + wordsize = 64 case. + +let add2 (xh, xl) (yh, yl) = + let zl = add xl yl and zh = add xh yh in + ((if ucompare zl xl < 0 then succ zh else zh), zl) + +let shl2 (xh, xl) n = + assert (0 < n && n < size + size); + if n < size + then (logor (shift_left xh n) (shift_right_logical xl (size - n)), + shift_left xl n) + else (shift_left xl (n - size), 0n) + +let mul2 x y = + let halfsize = size / 2 in + let halfmask = pred (shift_left 1n halfsize) in + let xl = logand x halfmask and xh = shift_right_logical x halfsize in + let yl = logand y halfmask and yh = shift_right_logical y halfsize in + add2 (mul xh yh, 0n) + (add2 (shl2 (0n, mul xl yh) halfsize) + (add2 (shl2 (0n, mul xh yl) halfsize) + (0n, mul xl yl))) + +let ucompare2 (xh, xl) (yh, yl) = + let c = ucompare xh yh in if c = 0 then ucompare xl yl else c + +let validate d m p = + let md = mul2 m d in + let one2 = (0n, 1n) in + let twoszp = shl2 one2 (size + p) in + let twop1 = shl2 one2 (p + 1) in + ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 +*) + +let rec div_int c1 c2 dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"])) + | (c1, Cconst_int 1) -> + c1 + | (Cconst_int 0 as c1, c2) -> + Csequence(c2, c1) + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 / n2) + | (c1, Cconst_int n) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + res = shift-right-signed(c1 + t, l) + *) + Cop(Casr, [bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) in + add_int c1 t); + Cconst_int l]) + else if n < 0 then + sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) dbg) + else begin + let (m, p) = divimm_parameters (Nativeint.of_int n) in + (* Algorithm: + t = multiply-high-signed(c1, m) + if m < 0, t = t + c1 + if p > 0, t = shift-right-signed(t, p) + res = t + sign-bit(c1) + *) + bind "dividend" c1 (fun c1 -> + let t = Cop(Cmulhi, [c1; Cconst_natint m]) in + let t = if m < 0n then Cop(Caddi, [t; c1]) else t in + let t = if p > 0 then Cop(Casr, [t; Cconst_int p]) else t in + add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)))) + end + | (c1, c2) when !Clflags.fast -> + Cop(Cdivi, [c1; c2]) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + Cifthenelse(c2, + Cop(Cdivi, [c1; c2]), + Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"]))) + +let mod_int c1 c2 dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"])) + | (c1, Cconst_int 1) -> + c1 + | (Cconst_int(0 | 1) as c1, c2) -> + Csequence(c2, c1) + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 mod n2) + | (c1, (Cconst_int n as c2)) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + t = bit-and(t, -n) + res = c1 - t + *) + bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) in + let t = add_int c1 t in + let t = Cop(Cand, [t; Cconst_int (-n)]) in + sub_int c1 t) + else + bind "dividend" c1 (fun c1 -> + sub_int c1 (mul_int (div_int c1 c2 dbg) c2)) + | (c1, c2) when !Clflags.fast -> + Cop(Cmodi, [c1; c2]) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + Cifthenelse(c2, + Cop(Cmodi, [c1; c2]), + Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"]))) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) +let is_different_from x = function + Cconst_int n -> n <> x + | Cconst_natint n -> n <> Nativeint.of_int x + | _ -> false + let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = bind "dividend" c1 (fun c1 -> bind "divisor" c2 (fun c2 -> - let c3 = - if Arch.division_crashes_on_overflow - && (size_int = 4 || bi <> Pint32) - && not (is_different_from (-1) c2) - then - Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) - else - mkop c1 c2 in - if !Clflags.fast || is_different_from 0 c2 then - c3 - else - Cifthenelse(c2, c3, - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"])))) + let c = mkop c1 c2 dbg in + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Pint32) + && not (is_different_from (-1) c2) + then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), c, mkm1 c1) + else c)) let safe_div_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) - (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) + safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) let safe_mod_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) - (fun c1 -> Cconst_int 0) + safe_divmod_bi mod_int (fun c1 -> Cconst_int 0) (* Bool *) @@ -360,13 +545,15 @@ let float_array_set arr ofs newval = (* String length *) +(* Length of string block *) + let string_length exp = bind "str" exp (fun str -> let tmp_var = Ident.create "tmp" in Clet(tmp_var, Cop(Csubi, [Cop(Clsl, - [Cop(Clsr, [header str; Cconst_int 10]); + [get_size str; Cconst_int log2_size_addr]); Cconst_int 1]), Cop(Csubi, @@ -398,7 +585,7 @@ let call_cached_method obj tag cache pos args dbg = let make_alloc_generic set_fn tag wordsize args = if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) + Cop(Calloc, Cconst_blockheader(block_header tag wordsize) :: args) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function @@ -484,32 +671,20 @@ let transl_comparison = function (* Translate structured constants *) -(* Fabrice: moved to compilenv.ml ---- -let const_label = ref 0 - -let new_const_label () = - incr const_label; - !const_label - -let new_const_symbol () = - incr const_label; - Compilenv.make_symbol (Some (string_of_int !const_label)) - -let structured_constants = ref ([] : (string * structured_constant) list) -*) - let transl_constant = function - Const_base(Const_int n) -> + | Uconst_int n -> int_const n - | Const_base(Const_char c) -> - Cconst_int(((Char.code c) lsl 1) + 1) - | Const_pointer n -> + | Uconst_ptr n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) - | cst -> - Cconst_symbol (Compilenv.new_structured_constant cst false) + | Uconst_ref (label, _) -> + Cconst_symbol label + +let transl_structured_constant cst = + let label = Compilenv.new_structured_constant cst ~shared:true in + Cconst_symbol label (* Translate constant closures *) @@ -520,9 +695,9 @@ let constant_closures = let box_int_constant bi n = match bi with - Pnativeint -> Const_base(Const_nativeint n) - | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) - | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) + Pnativeint -> Uconst_nativeint n + | Pint32 -> Uconst_int32 (Nativeint.to_int32 n) + | Pint64 -> Uconst_int64 (Int64.of_nativeint n) let operations_boxed_int bi = match bi with @@ -539,9 +714,9 @@ let alloc_header_boxed_int bi = let box_int bi arg = match arg with Cconst_int n -> - transl_constant (box_int_constant bi (Nativeint.of_int n)) + transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) | Cconst_natint n -> - transl_constant (box_int_constant bi n) + transl_structured_constant (box_int_constant bi n) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian @@ -824,8 +999,22 @@ let unaligned_set_64 ptr idx newval = Cop(Cstore Byte_unsigned, [add_int (add_int ptr idx) (Cconst_int 7); b8])))) +let max_or_zero a = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)]) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)]) in + Cop(Cand, [sign_negation; a])) + let check_bound unsafe dbg a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + if unsafe then k + else Csequence(make_checkbound dbg [max_or_zero a1;a2], k) (* Simplification of some primitives into C calls *) @@ -888,28 +1077,9 @@ let simplif_primitive p = (* Build switchers both for constants and blocks *) -(* constants first *) - let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) -let make_switch_gen arg cases acts = - let lcases = Array.length cases in - let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in - - for i = 0 to Array.length cases-1 do - let act = cases.(i) in - let new_act = store.Switch.act_store act in - new_cases.(i) <- new_act - done ; - Cswitch - (arg, new_cases, - Array.map - (fun n -> acts.(n)) - (store.Switch.act_get ())) - - -(* Then for blocks *) +(* Build an actual switch (ie jump table) *) module SArgBlocks = struct @@ -925,19 +1095,97 @@ struct type act = expression let default = Cexit (0,[]) + let make_const i = Cconst_int i let make_prim p args = Cop (p,args) let make_offset arg n = add_const arg n let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) - let make_switch arg cases actions = - make_switch_gen arg cases actions + let make_switch arg cases actions = Cswitch (arg,cases,actions) let bind arg body = bind "switcher" arg body + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> Ccatch (i,[],body,handler)) + + let make_exit i = Cexit (i,[]) + end +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + end) + module SwitcherBlocks = Switch.Make(SArgBlocks) +(* Int switcher, arg in [low..high], + cases is list of individual cases, and is sorted by first component *) + +let transl_int_switch arg low high cases default = match cases with +| [] -> assert false +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + a + (Array.of_list inters) store) + + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -946,8 +1194,8 @@ type unboxed_number_kind = | Boxed_float | Boxed_integer of boxed_integer -let is_unboxed_number = function - Uconst(Const_base(Const_float f), _) -> +let rec is_unboxed_number = function + Uconst(Uconst_ref(_, Uconst_float _)) -> Boxed_float | Uprim(p, _, _) -> begin match simplif_primitive p with @@ -988,9 +1236,10 @@ let is_unboxed_number = function | Pbbswap bi -> Boxed_integer bi | _ -> No_unboxing end + | Ulet (_, _, e) | Usequence (_, e) -> is_unboxed_number e | _ -> No_unboxing -let subst_boxed_number unbox_fn boxed_id unboxed_id exp = +let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = let need_boxed = ref false in let assigned = ref false in let rec subst = function @@ -1004,10 +1253,14 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp = end else Cassign(id, subst arg) | Ctuple argv -> Ctuple(List.map subst argv) - | Cop(Cload _, [Cvar id]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e - | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e + | Cop(Cload chunk, [Cvar id]) as e -> + if Ident.same id boxed_id && chunk = box_chunk && box_offset = 0 + then Cvar unboxed_id + else e + | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])]) as e -> + if Ident.same id boxed_id && chunk = box_chunk && ofs = box_offset + then Cvar unboxed_id + else e | Cop(op, argv) -> Cop(op, List.map subst argv) | Csequence(e1, e2) -> Csequence(subst e1, subst e2) | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) @@ -1025,12 +1278,19 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp = let functions = (Queue.create() : ufunction Queue.t) +let strmatch_compile = + let module S = + Strmatch.Make + (struct + let string_block_length = get_size + let transl_switch = transl_int_switch + end) in + S.compile + let rec transl = function Uvar id -> Cvar id - | Uconst (sc, Some const_label) -> - Cconst_symbol const_label - | Uconst (sc, None) -> + | Uconst sc -> transl_constant sc | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in @@ -1098,9 +1358,12 @@ let rec transl = function Clet(id, transl exp, transl body) | Boxed_float -> transl_unbox_let box_float unbox_float transl_unbox_float + Double_u 0 id exp body | Boxed_integer bi -> transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi) + (if bi = Pint32 then Thirtytwo_signed else Word) + size_addr id exp body end | Uletrec(bindings, body) -> @@ -1112,7 +1375,7 @@ let rec transl = function (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) | (Pmakeblock(tag, mut), []) -> - transl_constant(Const_block(tag, [])) + assert false | (Pmakeblock(tag, mut), args) -> make_alloc tag (List.map transl args) | (Pccall prim, args) -> @@ -1125,7 +1388,7 @@ let rec transl = function dbg), List.map transl args) | (Pmakearray kind, []) -> - transl_constant(Const_block(0, [])) + transl_structured_constant (Uconst_block(0, [])) | (Pmakearray kind, args) -> begin match kind with Pgenarray -> @@ -1197,6 +1460,11 @@ let rec transl = function (untag_int arg) s.us_index_consts s.us_actions_consts, transl_switch (get_tag arg) s.us_index_blocks s.us_actions_blocks)) + | Ustringswitch(arg,sw,d) -> + bind "switch" (transl arg) + (fun arg -> + strmatch_compile arg (Misc.may_map transl d) + (List.map (fun (s,act) -> s,transl act) sw)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) | Ucatch(nfail, [], body, handler) -> @@ -1289,9 +1557,11 @@ and transl_prim_1 p arg dbg = Cop(Cload Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) + | Pint_as_pointer -> + Cop(Cadda, [transl arg; Cconst_int (-1)]) (* Exceptions *) - | Praise -> - Cop(Craise dbg, [transl arg]) + | Praise k -> + Cop(Craise (k, dbg), [transl arg]) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) @@ -1309,7 +1579,7 @@ and transl_prim_1 p arg dbg = if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) + transl_prim_2 Paddint arg (Uconst (Uconst_int n)) Debuginfo.none | Poffsetref n -> return_unit @@ -1408,13 +1678,11 @@ and transl_prim_2 p arg1 arg2 dbg = | Psubint -> incr_int(sub_int (transl arg1) (transl arg2)) | Pmulint -> - incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) + incr_int(mul_int (decr_int(transl arg1)) (untag_int(transl arg2))) | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) + tag_int(div_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) + tag_int(mod_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1741,25 +2009,26 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = fatal_error "Cmmgen.transl_prim_3" and transl_unbox_float = function - Uconst(Const_base(Const_float f), _) -> Cconst_float f + Uconst(Uconst_ref(_, Uconst_float f)) -> Cconst_float f | exp -> unbox_float(transl exp) and transl_unbox_int bi = function - Uconst(Const_base(Const_int32 n), _) -> + Uconst(Uconst_ref(_, Uconst_int32 n)) -> Cconst_natint (Nativeint.of_int32 n) - | Uconst(Const_base(Const_nativeint n), _) -> + | Uconst(Uconst_ref(_, Uconst_nativeint n)) -> Cconst_natint n - | Uconst(Const_base(Const_int64 n), _) -> + | Uconst(Uconst_ref(_, Uconst_int64 n)) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' -> + | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) -and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = +and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset + id exp body = let unboxed_id = Ident.create (Ident.name id) in let trbody1 = transl body in let (trbody2, need_boxed, is_assigned) = - subst_boxed_number unbox_fn id unboxed_id trbody1 in + subst_boxed_number unbox_fn id unboxed_id box_chunk box_offset trbody1 in if need_boxed && is_assigned then Clet(id, transl exp, trbody1) else @@ -1784,8 +2053,8 @@ and make_catch2 mk_body handler = match handler with and exit_if_true cond nfail otherwise = match cond with - | Uconst (Const_pointer 0, _) -> otherwise - | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 0) -> otherwise + | Uconst (Uconst_ptr 1) -> Cexit (nfail,[]) | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) | Uprim(Psequand, _, _) -> @@ -1814,8 +2083,8 @@ and exit_if_true cond nfail otherwise = and exit_if_false cond otherwise nfail = match cond with - | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) - | Uconst (Const_pointer 1, _) -> otherwise + | Uconst (Uconst_ptr 0) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 1) -> otherwise | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail | Uprim(Psequor, _, _) -> @@ -1846,9 +2115,13 @@ and transl_switch arg index cases = match Array.length cases with | 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> + let cases = Array.map transl cases in + let store = StoreExp.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store cases.(j)) + index in let n_index = Array.length index in - let actions = Array.map transl cases in - let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) @@ -1865,13 +2138,15 @@ and transl_switch arg index cases = match Array.length cases with end done ; inters := (0, !this_high, !this_act) :: !inters ; - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (0,n_index-1) - (fun i -> Cconst_int i) - a - (Array.of_list !inters) actions) + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + a + (Array.of_list inters) store) and transl_letrec bindings cont = let bsz = @@ -1935,99 +2210,42 @@ let rec transl_all_functions already_translated cont = (* Emit structured constants *) -let immstrings = Hashtbl.create 17 - -let rec emit_constant symb cst cont = +let rec emit_structured_constant symb cst cont = + let emit_block white_header symb cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: Cdefine_symbol symb :: cont + in match cst with - Const_base(Const_float s) -> - Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont - | Const_base(Const_string s) | Const_immstring s -> - Cint(string_header (String.length s)) :: - Cdefine_symbol symb :: - emit_string_constant s cont - | Const_base(Const_int32 n) -> - Cint(boxedint32_header) :: Cdefine_symbol symb :: - emit_boxed_int32_constant n cont - | Const_base(Const_int64 n) -> - Cint(boxedint64_header) :: Cdefine_symbol symb :: - emit_boxed_int64_constant n cont - | Const_base(Const_nativeint n) -> - Cint(boxedintnat_header) :: Cdefine_symbol symb :: - emit_boxed_nativeint_constant n cont - | Const_block(tag, fields) -> - let (emit_fields, cont1) = emit_constant_fields fields cont in - Cint(block_header tag (List.length fields)) :: - Cdefine_symbol symb :: - emit_fields @ cont1 - | Const_float_array(fields) -> - Cint(floatarray_header (List.length fields)) :: - Cdefine_symbol symb :: - Misc.map_end (fun f -> Cdouble f) fields cont - | _ -> fatal_error "gencmm.emit_constant" - -and emit_constant_fields fields cont = - match fields with - [] -> ([], cont) - | f1 :: fl -> - let (data1, cont1) = emit_constant_field f1 cont in - let (datal, contl) = emit_constant_fields fl cont1 in - (data1 :: datal, contl) - -and emit_constant_field field cont = - match field with - Const_base(Const_int n) -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_base(Const_char c) -> - (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) - | Const_base(Const_float s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) - | Const_base(Const_string s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - | Const_immstring s -> - begin try - (Clabel_address (Hashtbl.find immstrings s), cont) - with Not_found -> - let lbl = Compilenv.new_const_label() in - Hashtbl.add immstrings s lbl; - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - end - | Const_base(Const_int32 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint32_header) :: Cdefine_label lbl :: - emit_boxed_int32_constant n cont) - | Const_base(Const_int64 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint64_header) :: Cdefine_label lbl :: - emit_boxed_int64_constant n cont) - | Const_base(Const_nativeint n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedintnat_header) :: Cdefine_label lbl :: - emit_boxed_nativeint_constant n cont) - | Const_pointer n -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_block(tag, fields) -> - let lbl = Compilenv.new_const_label() in - let (emit_fields, cont1) = emit_constant_fields fields cont in - (Clabel_address lbl, - Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: - emit_fields @ cont1) - | Const_float_array(fields) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: - Misc.map_end (fun f -> Cdouble f) fields cont) + | Uconst_float s-> + emit_block float_header symb (Cdouble s :: cont) + | Uconst_string s -> + emit_block (string_header (String.length s)) symb + (emit_string_constant s cont) + | Uconst_int32 n -> + emit_block boxedint32_header symb + (emit_boxed_int32_constant n cont) + | Uconst_int64 n -> + emit_block boxedint64_header symb + (emit_boxed_int64_constant n cont) + | Uconst_nativeint n -> + emit_block boxedintnat_header symb + (emit_boxed_nativeint_constant n cont) + | Uconst_block (tag, csts) -> + let cont = List.fold_right emit_constant csts cont in + emit_block (block_header tag (List.length csts)) symb cont + | Uconst_float_array fields -> + emit_block (floatarray_header (List.length fields)) symb + (Misc.map_end (fun f -> Cdouble f) fields cont) + +and emit_constant cst cont = + match cst with + | Uconst_int n | Uconst_ptr n -> + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + :: cont + | Uconst_ref (label, _) -> + Csymbol_address label :: cont and emit_string_constant s cont = let n = size_int - 1 - (String.length s) mod size_int in @@ -2075,7 +2293,7 @@ let emit_constant_closure symb fundecls cont = Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: Csymbol_address f2.label :: emit_others (pos + 4) rem in - Cint(closure_header (fundecls_size fundecls)) :: + Cint(black_closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: if f1.arity = 1 then Csymbol_address f1.label :: @@ -2093,14 +2311,12 @@ let emit_all_constants cont = let c = ref cont in List.iter (fun (lbl, global, cst) -> - let cst = emit_constant lbl cst [] in + let cst = emit_structured_constant lbl cst [] in let cst = if global then Cglobal_symbol lbl :: cst else cst in c:= Cdata(cst):: !c) (Compilenv.structured_constants()); -(* structured_constants := []; done in Compilenv.reset() *) - Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> c := Cdata(emit_constant_closure symb fundecls []) :: !c) @@ -2119,10 +2335,18 @@ let compunit size ulam = fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in - Cdata [Cint(block_header 0 size); + let space = + (* These words will be registered as roots and as such must contain + valid values, in case we are in no-naked-pointers mode. Likewise + the block header must be black, below (see [caml_darken]), since + the overall record may be referenced. *) + Array.to_list + (Array.init size (fun _index -> + Cint (Nativeint.of_int 1 (* Val_unit *)))) + in + Cdata ([Cint(black_block_header 0 size); Cglobal_symbol glob; - Cdefine_symbol glob; - Cskip(size * size_addr)] :: c3 + Cdefine_symbol glob] @ space) :: c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -2186,7 +2410,7 @@ let cache_public_method meths tag cache = *) let apply_function_body arity = - let arg = Array.create arity (Ident.create "arg") in + let arg = Array.make arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in let rec app_fun clos n = @@ -2466,8 +2690,8 @@ let reference_symbols namelist = let global_data name v = Cdata(Cglobal_symbol name :: - emit_constant name - (Const_base (Const_string (Marshal.to_string v []))) []) + emit_structured_constant name + (Uconst_string (Marshal.to_string v [])) []) let globals_map v = global_data "caml_globals_map" v @@ -2502,15 +2726,18 @@ let code_segment_table namelist = (* Initialize a predefined exception *) -let predef_exception name = - let bucketname = "caml_bucket_" ^ name in +let predef_exception i name = let symname = "caml_exn_" ^ name in + let cst = Uconst_string name in + let label = Compilenv.new_const_symbol () in + let cont = emit_structured_constant label cst [] in Cdata(Cglobal_symbol symname :: - emit_constant symname (Const_block(0,[Const_base(Const_string name)])) - [ Cglobal_symbol bucketname; - Cint(block_header 0 1); - Cdefine_symbol bucketname; - Csymbol_address symname ]) + emit_structured_constant symname + (Uconst_block(Obj.object_tag, + [ + Uconst_ref(label, cst); + Uconst_int (-i-1); + ])) cont) (* Header for a plugin *) diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 84db405f..46f94966 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -26,5 +26,5 @@ val globals_map: (string * Digest.t * Digest.t * string list) list -> val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase -val predef_exception: string -> Cmm.phrase +val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index c4e55796..51aa0440 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -26,8 +26,9 @@ type unit_infos = { mutable ui_name: string; (* Name of unit implemented *) mutable ui_symbol: string; (* Prefix for symbols *) mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) - mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) + mutable ui_imports_cmi: + (string * Digest.t option) list; (* Interfaces imported *) + mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) @@ -49,8 +50,8 @@ type library_infos = type dynunit = { dynu_name: string; dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t) list; - dynu_imports_cmx: (string * Digest.t) list; + dynu_imports_cmi: (string * Digest.t option) list; + dynu_imports_cmx: (string * Digest.t option) list; dynu_defines: string list; } diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 67ed8729..aff4ad62 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -47,7 +47,7 @@ let allocate_registers() = if reg.spill then begin (* Preallocate the registers in the stack *) let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in + let conflict = Array.make nslots false in List.iter (fun r -> match r.loc with @@ -84,14 +84,14 @@ let allocate_registers() = (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) - let start_register = Array.create Proc.num_register_classes 0 in + let start_register = Array.make Proc.num_register_classes 0 in (* Assign a location to a register, the best we can. *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in - let score = Array.create num_regs 0 in + let score = Array.make num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs <> 0 then begin @@ -161,7 +161,7 @@ let allocate_registers() = end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in + let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 6192f1e8..820b1b3f 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -27,7 +27,7 @@ let allocated_size = function let rec combine i allocstate = match i.desc with - Iend | Ireturn | Iexit _ | Iraise -> + Iend | Ireturn | Iexit _ | Iraise _ -> (i, allocated_size allocstate) | Iop(Ialloc sz) -> begin match allocstate with diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 17870c93..a313b972 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -27,8 +27,30 @@ exception Error of error let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) -let structured_constants = - ref ([] : (string * bool * Lambda.structured_constant) list) +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Pervasives.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 let current_unit = { ui_name = ""; @@ -69,7 +91,8 @@ let reset ?packname name = current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false; - structured_constants := [] + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty let current_unit_infos () = current_unit @@ -83,10 +106,19 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = | None -> prefix | Some id -> prefix ^ "__" ^ id +let symbol_in_current_unit name = + let prefix = "caml" ^ current_unit.ui_symbol in + name = prefix || + (let lp = String.length prefix in + String.length name >= 2 + lp + && String.sub name 0 lp = prefix + && name.[lp] = '_' + && name.[lp + 1] = '_') + let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = input_bytes ic (String.length cmx_magic_number) in + let buffer = really_input_string ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -101,7 +133,7 @@ let read_unit_info filename = let read_library_info filename = let ic = open_in_bin filename in - let buffer = input_bytes ic (String.length cmxa_magic_number) in + let buffer = really_input_string ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -111,9 +143,6 @@ let read_library_info filename = (* Read and cache info on global identifiers *) -let cmx_not_found_crc = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" - let get_global_info global_ident = ( let modname = Ident.name global_ident in if modname = current_unit.ui_name then @@ -129,9 +158,9 @@ let get_global_info global_ident = ( let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); - (Some ui, crc) + (Some ui, Some crc) with Not_found -> - (None, cmx_not_found_crc) in + (None, None) in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; @@ -199,7 +228,7 @@ let write_unit_info info filename = close_out oc let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imported_units(); + current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename @@ -214,12 +243,39 @@ let new_const_symbol () = incr const_label; make_symbol (Some (string_of_int !const_label)) -let new_structured_constant cst global = - let lbl = new_const_symbol() in - structured_constants := (lbl, global, cst) :: !structured_constants; - lbl +let snapshot () = !structured_constants +let backtrack s = structured_constants := s -let structured_constants () = !structured_constants +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let structured_constants () = + List.map + (fun (lbl, cst) -> + (lbl, Hashtbl.mem exported_constants lbl, cst) + ) (!structured_constants).strcst_all (* Error report *) @@ -236,3 +292,10 @@ let report_error ppf = function fprintf ppf "%a@ contains the description for unit\ @ %s when %s was expected" Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 51cb8c64..7fae3bad 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -31,6 +31,10 @@ val make_symbol: ?unitname:string -> string option -> string corresponds to symbol [id] in the compilation unit [u] (or the current unit). *) +val symbol_in_current_unit: string -> bool + (* Return true if the given asm symbol belongs to the + current compilation unit, false otherwise. *) + val symbol_for_global: Ident.t -> string (* Return the asm symbol that refers to the given global identifier *) @@ -50,9 +54,19 @@ val need_send_fun: int -> unit val new_const_symbol : unit -> string val new_const_label : unit -> int -val new_structured_constant : Lambda.structured_constant -> bool -> string -val structured_constants : - unit -> (string * bool * Lambda.structured_constant) list + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structually equal constant *) + string +val structured_constants: + unit -> (string * bool * Clambda.ustructured_constant) list +val add_exported_constant: string -> unit + +type structured_constants +val snapshot: unit -> structured_constants +val backtrack: structured_constants -> unit + val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) @@ -65,10 +79,6 @@ val cache_unit_info: unit_infos -> unit honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) -val cmx_not_found_crc: Digest.t - (* Special digest used in the [ui_imports_cmx] list to signal - that no [.cmx] file was found and used for the imported unit *) - val read_library_info: string -> library_infos type error = diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml new file mode 100644 index 00000000..cb93c286 --- /dev/null +++ b/asmcomp/deadcode.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +open Mach + +(* [deadcode i] returns a pair of an optimized instruction [i'] + and a set of registers live "before" instruction [i]. *) + +let rec deadcode i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live i.arg) + | Iop op -> + let (s, before) = deadcode i.next in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array before i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + assert (Array.length i.res > 0); (* sanity check *) + (s, before) + end else begin + ({i with next = s}, Reg.add_set_array i.live i.arg) + end + | Iifthenelse(test, ifso, ifnot) -> + let (ifso', _) = deadcode ifso in + let (ifnot', _) = deadcode ifnot in + let (s, _) = deadcode i.next in + ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, + Reg.add_set_array i.live i.arg) + | Iswitch(index, cases) -> + let cases' = Array.map (fun c -> fst (deadcode c)) cases in + let (s, _) = deadcode i.next in + ({i with desc = Iswitch(index, cases'); next = s}, + Reg.add_set_array i.live i.arg) + | Iloop(body) -> + let (body', _) = deadcode body in + let (s, _) = deadcode i.next in + ({i with desc = Iloop body'; next = s}, i.live) + | Icatch(nfail, body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) + | Iexit nfail -> + (i, i.live) + | Itrywith(body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Itrywith(body', handler'); next = s}, i.live) + +let fundecl f = + let (new_body, _) = deadcode f.fun_body in + {f with fun_body = new_body} diff --git a/asmcomp/deadcode.mli b/asmcomp/deadcode.mli new file mode 100644 index 00000000..6aafae05 --- /dev/null +++ b/asmcomp/deadcode.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 3ad467cb..24a621b3 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -88,16 +88,10 @@ let emit_bytes_directive directive s = done; if !pos > 0 then emit_char '\n' -(* PR#4813: assemblers do strange things with float literals indeed, - so we convert to IEEE representation ourselves and emit float - literals as 32- or 64-bit integers. *) - -let emit_float64_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_directive directive x = emit_printf "\t%s\t0x%Lx\n" directive x -let emit_float64_split_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_split_directive directive x = let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" @@ -105,8 +99,7 @@ let emit_float64_split_directive directive f = (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) -let emit_float32_directive directive f = - let x = Int32.bits_of_float (float_of_string f) in +let emit_float32_directive directive x = emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) @@ -221,9 +214,9 @@ let reset_debug_info () = let emit_debug_info dbg = if is_cfi_enabled () && (!Clflags.debug || Config.with_frame_pointers) - && not (Debuginfo.is_none dbg) then begin + && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *) + then begin let line = dbg.Debuginfo.dinfo_line in - assert (line <> 0); (* clang errors out on zero line numbers *) let file_name = dbg.Debuginfo.dinfo_file in let file_num = try List.assoc file_name !file_pos_nums @@ -239,3 +232,7 @@ let emit_debug_info dbg = emit_int file_num; emit_char '\t'; emit_int line; emit_char '\n' end + +let reset () = + reset_debug_info (); + frame_descriptors := [] diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index cc479d8c..486a5839 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -23,10 +23,11 @@ val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit -val emit_float64_directive: string -> string -> unit -val emit_float64_split_directive: string -> string -> unit -val emit_float32_directive: string -> string -> unit +val emit_float64_directive: string -> int64 -> unit +val emit_float64_split_directive: string -> int64 -> unit +val emit_float32_directive: string -> int32 -> unit +val reset : unit -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml new file mode 100644 index 00000000..6bea76f1 --- /dev/null +++ b/asmcomp/i386/CSE.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the i386 *) + +open Cmm +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + (* Operations that affect the floating-point stack cannot be factored *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint + | Iload((Single | Double | Double_u), _) -> Op_other + (* Specific ops *) + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific _ -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_symbol _ -> true + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index d2f9fd61..1d486db3 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -31,11 +31,12 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) - | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) @@ -105,11 +106,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg - (Nativeint.to_string n) - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> @@ -152,5 +156,7 @@ let print_specific_operation printreg op ppf arg = let stack_alignment = match Config.system with - | "macosx" -> 16 - | _ -> 4 + | "win32" -> 4 (* MSVC *) + | _ -> 16 +(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index ec8ec5d8..98df5f95 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -412,15 +412,16 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -458,15 +459,15 @@ let emit_instr fallthrough i = else ` movl {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end else ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -476,7 +477,7 @@ let emit_instr fallthrough i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -543,7 +544,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` fldl {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -615,6 +616,8 @@ let emit_instr fallthrough i = | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` imull {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` @@ -624,21 +627,6 @@ let emit_instr fallthrough i = ` incl {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - `{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` movl {emit_reg i.arg.(0)}, %eax\n`; - ` testl %eax, %eax\n`; - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, %eax\n`; - `{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`; - ` subl %eax, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` @@ -696,9 +684,9 @@ let emit_instr fallthrough i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -830,11 +818,16 @@ let emit_instr fallthrough i = ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call {emit_symbol "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; ` popl {emit_symbol "caml_exception_pointer"}\n`; if trap_frame_size > 8 then @@ -968,9 +961,9 @@ let emit_item = function | Cint n -> ` .long {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".long" f + emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index b233f818..ef5205ef 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -62,7 +62,10 @@ let add_used_symbol s = let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +(* Output a 32 or 64 bit integer in hex *) + let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Output a label *) @@ -361,36 +364,20 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` (* Output the assembly code for an instruction *) @@ -419,15 +406,15 @@ let emit_instr i = else ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -437,7 +424,7 @@ let emit_instr i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -493,7 +480,7 @@ let emit_instr i = | Double | Double_u -> ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -565,6 +552,8 @@ let emit_instr i = | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop Imulh) -> + ` imul {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` @@ -574,21 +563,6 @@ let emit_instr i = ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` mov eax, {emit_reg i.arg.(0)}\n`; - ` test eax, eax\n`; - ` jge {emit_label lbl}\n`; - ` add eax, {emit_int(n-1)}\n`; - `{emit_label lbl}: and eax, {emit_int(-n)}\n`; - ` sub {emit_reg i.arg.(0)}, eax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` @@ -644,9 +618,9 @@ let emit_instr i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> add_used_symbol s ; ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -769,11 +743,16 @@ let emit_instr i = ` pop _caml_exception_pointer\n`; ` add esp, 4\n`; stack_offset := !stack_offset - 8 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call _caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call _caml_reraise_exn\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` mov esp, _caml_exception_pointer\n`; ` pop _caml_exception_pointer\n`; ` ret\n` @@ -824,9 +803,9 @@ let emit_item = function | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s ; ` DWORD {emit_symbol s}\n` @@ -861,6 +840,7 @@ let begin_assembly() = ` EXTERN _caml_alloc3: PROC\n`; ` EXTERN _caml_ml_array_bound_error: PROC\n`; ` EXTERN _caml_raise_exn: PROC\n`; + ` EXTERN _caml_reraise_exn: PROC\n`; ` .DATA\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index e946f699..0b010d24 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -72,7 +72,7 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 7 Reg.dummy in + let v = Array.make 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v @@ -111,7 +111,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in @@ -154,6 +154,21 @@ let loc_external_results res = let loc_exn_bucket = eax +(* Volatile registers: the x87 top of FP stack is *) + +let reg_is_volatile = function + | { typ = Float; loc = Reg _ } -> true + | _ -> false + +let regs_are_volatile rs = + try + for i = 0 to Array.length rs - 1 do + if reg_is_volatile rs.(i) then raise Exit + done; + false + with Exit -> + true + (* Registers destroyed by operations *) let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) @@ -163,8 +178,7 @@ let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] - | Iop(Iintop_imm(Imod, _)) -> [| eax |] - | Iop(Ialloc _) -> [| eax |] + | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] | Iop(Iintoffloat) -> [| eax |] | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] @@ -183,6 +197,17 @@ let max_register_pressure = function Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 623d12a8..bc1b08f5 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -57,9 +57,11 @@ method! reload_operation op arg res = if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r|], [|r|]) else (arg, res) - | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | - Ispecific(Ipush) -> + | Iintop(Imulh | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) + | Ifloatofint | Iintoffloat | Ispecific(Ipush) -> (* The argument(s) can be either in register or on stack *) + (* Note: Imulh: arg(0 and res(0) already forced in regs + Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index cdf7fdfc..10d2d40e 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -110,8 +110,12 @@ let pseudoregs_for_operation op arg res = Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> ([|res.(0); arg.(1)|], res, false) (* Two-address unary operations *) - | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> (res, res, false) + (* For imull, first arg must be in eax, eax is clobbered, and result is in + edx. *) + | Iintop(Imulh) -> + ([| eax; arg.(1) |], [| edx |], true) (* For shifts with variable shift count, second arg must be in ecx *) | Iintop(Ilsl|Ilsr|Iasr) -> ([|res.(0); ecx|], res, false) @@ -122,10 +126,6 @@ let pseudoregs_for_operation op arg res = ([| eax; ecx |], [| eax |], true) | Iintop(Imod) -> ([| eax; ecx |], [| edx |], true) - (* For mod with immediate operand, arg must not be in eax. - Keep it simple, force it in edx. *) - | Iintop_imm(Imod, _) -> - ([| edx |], [| edx |], true) (* For floating-point operations and floating-point loads, the result is always left at the top of the floating-point stack *) | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -135,7 +135,7 @@ let pseudoregs_for_operation op arg res = (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr) -> + | Istore((Byte_unsigned | Byte_signed), addr, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -178,20 +178,20 @@ method select_addressing chunk exp = | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -202,19 +202,6 @@ method! select_operation op args = | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. In passing, apply Ershov's algorithm to reduce stack usage *) | Caddf -> @@ -241,6 +228,9 @@ method! select_operation op args = | Cextcall(fn, ty_res, false, dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) + (* i386 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) (* Default *) | _ -> super#select_operation op args @@ -298,6 +288,9 @@ method select_push exp = (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) +method! mark_c_tailcall = + Proc.contains_calls := true + method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 77acb78a..2d541eee 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -111,17 +111,21 @@ let build_graph fundecl = | Itrywith(body, handler) -> add_interf_set Proc.destroyed_at_raise handler.live; interf body; interf handler; interf i.next - | Iraise -> () in + | Iraise _ -> () in (* Add a preference from one reg to another. Do not add anything if the two registers conflict, - or if the source register already has a location. *) + or if the source register already has a location, + or if the two registers belong to different classes. + (The last case can occur e.g. on Sparc when passing + float arguments in integer registers, PR#6227.) *) let add_pref weight r1 r2 = if weight > 0 then begin let i = r1.stamp and j = r2.stamp in if i <> j && r1.loc = Unknown + && Proc.register_class r1 = Proc.register_class r2 && (let p = if i < j then (i, j) else (j, i) in not (IntPairSet.mem p !mat)) then r1.prefer <- (r2, weight) :: r1.prefer @@ -178,7 +182,7 @@ let build_graph fundecl = () | Itrywith(body, handler) -> prefer weight body; prefer weight handler; prefer weight i.next - | Iraise -> () + | Iraise _ -> () in interf fundecl.fun_body; prefer 8 fundecl.fun_body diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 963ffe9a..64678c1d 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -42,10 +42,10 @@ and instruction_desc = | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Lambda.raise_kind let has_fallthrough = function - | Lreturn | Lbranch _ | Lswitch _ | Lraise + | Lreturn | Lbranch _ | Lswitch _ | Lraise _ | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false | _ -> true @@ -126,9 +126,9 @@ let rec discard_dead_code n = match n.desc with Lend -> n | Llabel _ -> n -(* Do not discard Lpoptrap or Istackoffset instructions, +(* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) - | Lpoptrap -> n + | Lpoptrap | Lpushtrap -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next @@ -148,20 +148,30 @@ let add_branch lbl n = else discard_dead_code n -(* Current labels for exit handler *) +let try_depth = ref 0 + +(* Association list: exit handler -> (handler label, try-nesting factor) *) let exit_label = ref [] -let find_exit_label k = +let find_exit_label_try_depth k = try List.assoc k !exit_label with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" +let find_exit_label k = + let (label, t) = find_exit_label_try_depth k in + assert(t = !try_depth); + label + let is_next_catch n = match !exit_label with -| (n0,_)::_ when n0=n -> true +| (n0,(_,t))::_ when n0=n && t = !try_depth -> true | _ -> false +let local_exit k = + snd (find_exit_label_try_depth k) = !try_depth + (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = @@ -187,15 +197,15 @@ let rec linear i n = | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) | Iexit nfail1, Iexit nfail2, _ - when is_next_catch nfail1 -> + when is_next_catch nfail1 && local_exit nfail2 -> let lbl2 = find_exit_label nfail2 in copy_instr (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) - | Iexit nfail, _, _ -> + | Iexit nfail, _, _ when local_exit nfail -> let n2 = linear ifnot n1 and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 - | _, Iexit nfail, _ -> + | _, Iexit nfail, _ when local_exit nfail -> let n2 = linear ifso n1 in let lbl = find_exit_label nfail in copy_instr (Lcondbranch(invert_test test, lbl)) i n2 @@ -214,7 +224,7 @@ let rec linear i n = (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> - let lbl_cases = Array.create (Array.length cases) 0 in + let lbl_cases = Array.make (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do @@ -242,23 +252,43 @@ let rec linear i n = | Icatch(io, body, handler) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in let (lbl_handler, n2) = get_label(linear handler n1) in - exit_label := (io, lbl_handler) :: !exit_label ; + exit_label := (io, (lbl_handler, !try_depth)) :: !exit_label ; let n3 = linear body (add_branch lbl_end n2) in exit_label := List.tl !exit_label; n3 | Iexit nfail -> - let n1 = linear i.Mach.next n in - let lbl = find_exit_label nfail in - add_branch lbl n1 + let lbl, t = find_exit_label_try_depth nfail in + (* We need to re-insert dummy pushtrap (which won't be executed), + so as to preserve stack offset during assembler generation. + It would make sense to have a special pseudo-instruction + only to inform the later pass about this stack offset + (corresponding to N traps). + *) + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpushtrap i) (tt - 1) + in + let n1 = loop (linear i.Mach.next n) !try_depth in + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpoptrap i) (tt - 1) + in + loop (add_branch lbl n1) !try_depth | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in + incr try_depth; let (lbl_body, n2) = get_label (cons_instr Lpushtrap (linear body (cons_instr Lpoptrap n1))) in + decr try_depth; cons_instr (Lsetuptrap lbl_body) (linear handler (add_branch lbl_join n2)) - | Iraise -> - copy_instr Lraise i (discard_dead_code n) + | Iraise k -> + copy_instr (Lraise k) i (discard_dead_code n) + +let reset () = + label_counter := 99; + exit_label := [] let fundecl f = { fun_name = f.Mach.fun_name; diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index ad5dc3a9..2996a29b 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -36,7 +36,7 @@ and instruction_desc = | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Lambda.raise_kind val has_fallthrough : instruction_desc -> bool val end_instr: instruction @@ -50,4 +50,5 @@ type fundecl = fun_fast: bool; fun_dbg : Debuginfo.t } +val reset : unit -> unit val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index b3085b6c..2ef322ef 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -16,13 +16,13 @@ open Mach let live_at_exit = ref [] + let find_live_at_exit k = try List.assoc k !live_at_exit with - | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit" -let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = @@ -37,8 +37,34 @@ let rec live i finally = i.live <- finally; finally | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (* i.live remains empty since no regs are live across *) + i.live <- Reg.Set.empty; (* no regs are live across *) Reg.set_of_array i.arg + | Iop op -> + let after = live i.next finally in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array after i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + (* This operation is dead code. Ignore its arguments. *) + i.live <- after; + after + end else begin + let across_after = Reg.diff_set_array after i.res in + let across = + match op with + | Icall_ind | Icall_imm _ | Iextcall _ + | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across i.arg + end | Iifthenelse(test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in @@ -89,24 +115,13 @@ let rec live i finally = live_at_raise := saved_live_at_raise; i.live <- before_body; before_body - | Iraise -> - (* i.live remains empty since no regs are live across *) + | Iraise _ -> + i.live <- !live_at_raise; Reg.add_set_array !live_at_raise i.arg - | _ -> - let across_after = Reg.diff_set_array (live i.next finally) i.res in - let across = - match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> - (* The function call may raise an exception, branching to the - nearest enclosing try ... with. Similarly for bounds checks. - Hence, everything that must be live at the beginning of - the exception handler must also be live across this instr. *) - Reg.Set.union across_after !live_at_raise - | _ -> - across_after in - i.live <- across; - Reg.add_set_array across i.arg + +let reset () = + live_at_raise := Reg.Set.empty; + live_at_exit := [] let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli index b52ec5a2..ed2f1a8a 100644 --- a/asmcomp/liveness.mli +++ b/asmcomp/liveness.mli @@ -15,4 +15,5 @@ open Format +val reset : unit -> unit val fundecl: formatter -> Mach.fundecl -> unit diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 3e7160b5..3a717476 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -17,7 +17,7 @@ type integer_comparison = | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound @@ -36,8 +36,9 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind @@ -45,7 +46,7 @@ type operation = | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int @@ -71,7 +72,7 @@ and instruction_desc = | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Lambda.raise_kind type fundecl = { fun_name: string; @@ -125,6 +126,6 @@ let rec instr_iter f i = | Iexit _ -> () | Itrywith(body, handler) -> instr_iter f body; instr_iter f handler; instr_iter f i.next - | Iraise -> () + | Iraise _ -> () | _ -> instr_iter f i.next diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 06fe1c33..618e5e4c 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -17,7 +17,7 @@ type integer_comparison = | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound @@ -36,16 +36,18 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string * bool + | Iextcall of string * bool (* false = noalloc, true = alloc *) | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + (* false = initialization, true = assignment *) | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int @@ -71,7 +73,7 @@ and instruction_desc = | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Lambda.raise_kind type fundecl = { fun_name: string; diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml new file mode 100644 index 00000000..ec10d2df --- /dev/null +++ b/asmcomp/power/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the PowerPC *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | Ispecific(Ialloc_far _) -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 283312e7..0a26ed14 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -45,13 +45,6 @@ let slot_offset loc cls = | Incoming n -> frame_size() + n | Outgoing n -> n -(* Whether stack backtraces are supported *) - -let supports_backtraces = - match Config.system with - | "rhapsody" -> true - | _ -> false - (* Output a symbol *) let emit_symbol = @@ -236,7 +229,7 @@ let record_frame live dbg = (* Record floating-point and large integer literals *) -let float_literals = ref ([] : (string * int) list) +let float_literals = ref ([] : (int64 * int) list) let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way @@ -266,15 +259,16 @@ let name_for_int_comparison = function (* Names for various instructions *) let name_for_intop = function - Iadd -> "add" - | Imul -> if ppc64 then "mulld" else "mullw" - | Idiv -> if ppc64 then "divd" else "divw" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> if ppc64 then "sld" else "slw" - | Ilsr -> if ppc64 then "srd" else "srw" - | Iasr -> if ppc64 then "srad" else "sraw" + Iadd -> "add" + | Imul -> if ppc64 then "mulld" else "mullw" + | Imulh -> if ppc64 then "mulhd" else "mulhw" + | Idiv -> if ppc64 then "divd" else "divw" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> if ppc64 then "sld" else "slw" + | Ilsr -> if ppc64 then "srd" else "srw" + | Iasr -> if ppc64 then "srad" else "sraw" | _ -> Misc.fatal_error "Emit.Intop" let name_for_intop_imm = function @@ -324,7 +318,8 @@ let load_store_size = function let instr_size = function Lend -> 0 | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 + | Lop(Iconst_int n | Iconst_blockheader n) -> + if is_native_immediate n then 1 else 2 | Lop(Iconst_float s) -> 2 | Lop(Iconst_symbol s) -> 2 | Lop(Icall_ind) -> 2 @@ -338,14 +333,12 @@ let instr_size = function if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr)) -> load_store_size addr + | Lop(Istore(chunk, addr, _)) -> load_store_size addr | Lop(Ialloc n) -> 4 | Lop(Ispecific(Ialloc_far n)) -> 5 | Lop(Iintop Imod) -> 3 | Lop(Iintop(Icomp cmp)) -> 4 | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Idiv, n)) -> 2 - | Lop(Iintop_imm(Imod, n)) -> 4 | Lop(Iintop_imm(Icomp cmp, n)) -> 4 | Lop(Iintop_imm(op, n)) -> 1 | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 @@ -365,7 +358,7 @@ let instr_size = function | Lsetuptrap lbl -> 1 | Lpushtrap -> 4 | Lpoptrap -> 2 - | Lraise -> 6 + | Lraise _ -> 6 let label_map code = let map = Hashtbl.create 37 in @@ -460,7 +453,7 @@ let rec emit_instr i dslot = | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin @@ -473,9 +466,9 @@ let rec emit_instr i dslot = ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> let lbl = new_label() in - float_literals := (s, lbl) :: !float_literals; + float_literals := (Int64.bits_of_float f, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> @@ -555,7 +548,7 @@ let rec emit_instr i dslot = emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let storeinstr = match chunk with Byte_unsigned | Byte_signed -> "stb" @@ -597,7 +590,7 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> @@ -605,16 +598,6 @@ let rec emit_instr i dslot = ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Isub, n)) -> ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` - | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_gpr 0}, {emit_gpr 0}\n`; - ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; - ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> @@ -625,7 +608,7 @@ let rec emit_instr i dslot = emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> @@ -645,8 +628,7 @@ let rec emit_instr i dslot = ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) + float_literals := (0x4330000080000000L, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; ` lis {emit_gpr 0}, 0x4330\n`; @@ -767,17 +749,22 @@ let rec emit_instr i dslot = ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug && supports_backtraces then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` bl {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` bl {emit_symbol "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; + ` mtctr {emit_gpr 0}\n`; ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` + ` bctr\n` end and emit_delay = function @@ -911,11 +898,11 @@ let emit_item = function | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f + then emit_float64_directive ".quad" (Int64.bits_of_float f) + else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 203e8a9e..934d2cbf 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -83,11 +83,11 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 23 Reg.dummy in + let v = Array.make 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 31 Reg.dummy in + let v = Array.make 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = @@ -103,7 +103,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack stack_ofs arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in @@ -157,7 +157,7 @@ let loc_results res = let poweropen_external_conventions first_int last_int first_float last_float arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (14 * size_addr) in @@ -200,6 +200,10 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -224,6 +228,17 @@ let max_register_pressure = function Iextcall(_, _) -> [| 15; 18 |] | _ -> [| 23; 30 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index e4a575e0..7adaa2ee 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -26,7 +26,7 @@ method oper_latency = function | Iload(_, _) -> 2 | Iconst_float _ -> 2 (* turned into a load *) | Iconst_symbol _ -> 1 - | Iintop Imul -> 9 + | Iintop(Imul | Imulh) -> 9 | Iintop_imm(Imul, _) -> 5 | Iintop(Idiv | Imod) -> 36 | Iaddf | Isubf -> 4 @@ -44,12 +44,10 @@ method reload_retaddr_latency = 12 method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _), _) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 - | Iintop_imm(Idiv, _) -> 2 - | Iintop_imm(Imod, _) -> 4 | Iintop_imm(Icomp _, _) -> 4 | Ifloatofint -> 9 | Iintoffloat -> 4 diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index a68c63fc..86aea05f 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -61,16 +61,8 @@ method select_addressing chunk exp = method! select_operation op args = match (op, args) with - (* Prevent the recognition of (x / cst) and (x % cst) when cst is not - a power of 2, which do not correspond to an instruction. *) - (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> - (Iintop Idiv, args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) - | (Cmodi, _) -> - (Iintop Imod, args) + (* PowerPC does not support immediate operands for multiply high *) + (Cmulhi, _) -> (Iintop Imulh, args) (* The and, or and xor instructions have a different range of immediate operands than the other instructions *) | (Cand, _) -> self#select_logical Iand args diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index a5081fc4..b28d749e 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -15,15 +15,33 @@ open Format open Asttypes open Clambda -let rec pr_idents ppf = function - | [] -> () - | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t +let rec structured_constant ppf = function + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x + | Uconst_block (tag, l) -> + fprintf ppf "block(%i" tag; + List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; + fprintf ppf ")" + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" + | Uconst_string s -> fprintf ppf "%S" s + +and uconstant ppf = function + | Uconst_ref (s, c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i let rec lam ppf = function | Uvar id -> Ident.print ppf id - | Uconst (cst,_) -> - Printlambda.structured_constant ppf cst + | Uconst c -> uconstant ppf c | Udirect_apply(f, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -36,7 +54,7 @@ let rec lam ppf = function let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = - fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in @@ -68,23 +86,38 @@ let rec lam ppf = function List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> - let switch ppf sw = - let spc = ref false in - for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) in - let l = sw.us_actions_consts.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" i lam l; - done; - for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) in - let l = sw.us_actions_blocks.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" i lam l; + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in fprintf ppf - "@[<1>(switch %a@ @[%a@])@]" + "@[@[<2>(switch@ %a@ @]%a)@]" lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -132,3 +165,29 @@ and sequence ppf ulam = match ulam with let clambda ppf ulam = fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli index ddc233af..d138b958 100644 --- a/asmcomp/printclambda.mli +++ b/asmcomp/printclambda.mli @@ -14,3 +14,5 @@ open Clambda open Format val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index f29bcbc4..89c8582a 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -60,6 +60,7 @@ let operation = function | Caddi -> "+" | Csubi -> "-" | Cmuli -> "*" + | Cmulhi -> "*h" | Cdivi -> "/" | Cmodi -> "mod" | Cand -> "and" @@ -81,13 +82,14 @@ let operation = function | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise d -> "raise" ^ Debuginfo.to_string d + | Craise (k, d) -> Lambda.raise_kind k ^ Debuginfo.to_string d | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) - | Cconst_float s -> fprintf ppf "%s" s + | Cconst_natint n | Cconst_blockheader n -> + fprintf ppf "%s" (Nativeint.to_string n) + | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) @@ -186,8 +188,8 @@ let data_item ppf = function | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) - | Csingle f -> fprintf ppf "single %s" f - | Cdouble f -> fprintf ppf "double %s" f + | Csingle f -> fprintf ppf "single %F" f + | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 6e177070..df58c5cc 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -60,8 +60,8 @@ let instr ppf i = fprintf ppf "push trap" | Lpoptrap -> fprintf ppf "pop trap" - | Lraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Lraise k -> + fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 6407f4f7..a39160d2 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -18,8 +18,8 @@ open Reg open Mach let reg ppf r = - if String.length r.name > 0 then - fprintf ppf "%s" r.name + if not (Reg.anonymous r) then + fprintf ppf "%s" (Reg.name r) else fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); fprintf ppf "/%i" r.stamp; @@ -70,6 +70,7 @@ let intop = function | Iadd -> " + " | Isub -> " - " | Imul -> " * " + | Imulh -> " *h " | Idiv -> " div " | Imod -> " mod " | Iand -> " & " @@ -102,8 +103,9 @@ let operation op arg ppf res = | Imove -> regs ppf arg | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg - | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float s -> fprintf ppf "%s" s + | Iconst_int n + | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_float f -> fprintf ppf "%F" f | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg @@ -111,18 +113,19 @@ let operation op arg ppf res = | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg | Iextcall(lbl, alloc) -> fprintf ppf "extcall \"%s\" %a%s" lbl regs arg - (if not alloc then "" else " (noalloc)") + (if alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg - | Istore(chunk, addr) -> - fprintf ppf "%s[%a] := %a" + | Istore(chunk, addr, is_assign) -> + fprintf ppf "%s[%a] := %a %s" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) + (if is_assign then "(assign)" else "(init)") | Ialloc n -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n @@ -177,8 +180,8 @@ let rec instr ppf i = | Itrywith(body, handler) -> fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" instr body instr handler - | Iraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Iraise k -> + fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf "%s" (Debuginfo.to_string i.dbg); diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 6cc6aedc..cabac4db 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -40,6 +40,12 @@ val max_register_pressure: Mach.operation -> int array val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array +(* Volatile registers: those that change value when read *) +val regs_are_volatile: Reg.t array -> bool + +(* Pure operations *) +val op_is_pure: Mach.operation -> bool + (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index 1ec0bf9e..8f0298a9 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -12,12 +12,30 @@ open Cmm +module Raw_name = struct + type t = + | Anon + | R + | Ident of Ident.t + + let create_from_ident ident = Ident ident + + let to_string t = + match t with + | Anon -> None + | R -> Some "R" + | Ident ident -> + let name = Ident.name ident in + if String.length name <= 0 then None else Some name +end + type t = - { mutable name: string; + { mutable raw_name: Raw_name.t; stamp: int; typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; + mutable part: int option; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; @@ -37,44 +55,65 @@ and stack_location = type reg = t let dummy = - { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } + { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown; + spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; + visited = false; part = None; + } let currstamp = ref 0 let reg_list = ref([] : t list) let create ty = - let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; - spill = false; interf = []; prefer = []; degree = 0; - spill_cost = 0; visited = false } in + let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty; + loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in reg_list := r :: !reg_list; incr currstamp; r let createv tyv = let n = Array.length tyv in - let rv = Array.create n dummy in + let rv = Array.make n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in - let rv' = Array.create n dummy in + let rv' = Array.make n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' let clone r = let nr = create r.typ in - nr.name <- r.name; + nr.raw_name <- r.raw_name; nr let at_location ty loc = - let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; - visited = false } in + let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc; + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in incr currstamp; r +let anonymous t = + match Raw_name.to_string t.raw_name with + | None -> true + | Some _raw_name -> false + +let name t = + match Raw_name.to_string t.raw_name with + | None -> "" + | Some raw_name -> + let with_spilled = + if t.spill then + "spilled-" ^ raw_name + else + raw_name + in + match t.part with + | None -> with_spilled + | Some part -> with_spilled ^ "#" ^ string_of_int part + let first_virtual_reg_stamp = ref (-1) let reset() = @@ -139,6 +178,16 @@ let inter_set_array s v = else inter_all(i+1) in inter_all 0 +let disjoint_set_array s v = + match Array.length v with + 0 -> true + | 1 -> not (Set.mem v.(0) s) + | n -> let rec disjoint_all i = + if i >= n then true + else if Set.mem v.(i) s then false + else disjoint_all (i+1) + in disjoint_all 0 + let set_of_array v = match Array.length v with 0 -> Set.empty diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index 889e026f..e3cb2d95 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -12,12 +12,18 @@ (* Pseudo-registers *) +module Raw_name : sig + type t + val create_from_ident : Ident.t -> t +end + type t = - { mutable name: string; (* Name (for printing) *) + { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) typ: Cmm.machtype_component; (* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) + mutable part: int option; (* Zero-based index of part of value *) mutable interf: t list; (* Other regs live simultaneously *) mutable prefer: (t * int) list; (* Preferences for other regs *) mutable degree: int; (* Number of other regs live sim. *) @@ -41,12 +47,18 @@ val createv_like: t array -> t array val clone: t -> t val at_location: Cmm.machtype_component -> location -> t +val anonymous : t -> bool + +(* Name for printing *) +val name : t -> string + module Set: Set.S with type elt = t module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t +val disjoint_set_array: Set.t -> t array -> bool val set_of_array: t array -> Set.t val reset: unit -> unit diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 8f40ad01..30f23a82 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -54,7 +54,7 @@ method makereg r = method private makeregs rv = let n = Array.length rv in - let newv = Array.create n Reg.dummy in + let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv @@ -88,7 +88,7 @@ method private reload i = already at the correct position (e.g. on stack for some arguments). However, something needs to be done for the function pointer in indirect calls. *) - Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i + Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i | Iop(Itailcall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 885c9454..f7af4436 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -138,6 +138,8 @@ let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) class virtual scheduler_generic = object (self) +val mutable trywith_nesting = 0 + (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) @@ -154,9 +156,16 @@ method oper_in_basic_block = function (* Determine whether an instruction ends a basic block or not *) -method private instr_in_basic_block instr = +(* PR#2719: it is generally incorrect to schedule checkbound instructions + within a try ... with Invalid_argument _ -> ... + Hence, a checkbound instruction within a try...with block ends the + current basic block. *) + +method private instr_in_basic_block instr try_nesting = match instr.desc with - Lop op -> self#oper_in_basic_block op + Lop op -> + self#oper_in_basic_block op && + not (try_nesting > 0 && self#is_checkbound op) | Lreloadretaddr -> true | _ -> false @@ -165,7 +174,7 @@ method private instr_in_basic_block instr = load or store instructions (e.g. on the I386). *) method is_store = function - Istore(_, _) -> true + Istore(_, _, _) -> true | _ -> false method is_load = function @@ -336,8 +345,8 @@ method private reschedule ready_queue date cont = if son.emitted_ancestors = son.ancestors then new_queue := son :: !new_queue) node.sons; - instr_cons node.instr.desc node.instr.arg node.instr.res - (self#reschedule !new_queue (date + issue_cycles) cont) + { node.instr with next = + self#reschedule !new_queue (date + issue_cycles) cont } end (* Entry point *) @@ -345,19 +354,21 @@ method private reschedule ready_queue date cont = method schedule_fundecl f = - let rec schedule i = + let rec schedule i try_nesting = match i.desc with - Lend -> i + | Lend -> i + | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> - if self#instr_in_basic_block i then begin + if self#instr_in_basic_block i try_nesting then begin clear_code_dag(); - schedule_block [] i + schedule_block [] i try_nesting end else - { i with next = schedule i.next } + { i with next = schedule i.next try_nesting } - and schedule_block ready_queue i = - if self#instr_in_basic_block i then - schedule_block (self#add_instruction ready_queue i) i.next + and schedule_block ready_queue i try_nesting = + if self#instr_in_basic_block i try_nesting then + schedule_block (self#add_instruction ready_queue i) i.next try_nesting else begin let critical_outputs = match i.desc with @@ -366,11 +377,11 @@ method schedule_fundecl f = | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; - self#reschedule ready_queue 0 (schedule i) + self#reschedule ready_queue 0 (schedule i try_nesting) end in if f.fun_fast then begin - let new_body = schedule f.fun_body in + let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; @@ -380,3 +391,5 @@ method schedule_fundecl f = f end + +let reset () = clear_code_dag () diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli index 6019d96f..911330f8 100644 --- a/asmcomp/schedgen.mli +++ b/asmcomp/schedgen.mli @@ -42,3 +42,5 @@ class virtual scheduler_generic : object (* Entry point *) method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl end + +val reset : unit -> unit diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 1d2bf96d..8871bf49 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -33,7 +33,7 @@ let oper_result_type = function end | Calloc -> typ_addr | Cstore c -> typ_void - | Caddi | Csubi | Cmuli | Cdivi | Cmodi | + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int | Cadda | Csuba -> typ_addr @@ -47,7 +47,8 @@ let oper_result_type = function let size_expr env exp = let rec size localenv = function - Cconst_int _ | Cconst_natint _ -> Arch.size_int + Cconst_int _ | Cconst_natint _ + | Cconst_blockheader _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float @@ -85,7 +86,7 @@ let swap_intcomp = function let all_regs_anonymous rv = try for i = 0 to Array.length rv - 1 do - if String.length rv.(i).name > 0 then raise Exit + if not (Reg.anonymous rv.(i)) then raise Exit done; true with Exit -> @@ -93,10 +94,11 @@ let all_regs_anonymous rv = let name_regs id rv = if Array.length rv = 1 then - rv.(0).name <- Ident.name id + rv.(0).raw_name <- Raw_name.create_from_ident id else for i = 0 to Array.length rv - 1 do - rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + rv.(i).raw_name <- Raw_name.create_from_ident id; + rv.(i).part <- Some i done (* "Join" two instruction sequences, making sure they return their results @@ -109,12 +111,12 @@ let join opt_r1 seq1 opt_r2 seq2 = | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); - let r = Array.create l1 Reg.dummy in + let r = Array.make l1 Reg.dummy in for i = 0 to l1-1 do - if String.length r1.(i).name = 0 then begin + if Reg.anonymous r1.(i) then begin r.(i) <- r1.(i); seq2#insert_move r2.(i) r1.(i) - end else if String.length r2.(i).name = 0 then begin + end else if Reg.anonymous r2.(i) then begin r.(i) <- r2.(i); seq1#insert_move r1.(i) r2.(i) end else begin @@ -137,7 +139,7 @@ let join_array rs = None -> None | Some template -> let size_res = Array.length template in - let res = Array.create size_res Reg.dummy in + let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do res.(i) <- Reg.create template.(i).typ done; @@ -153,7 +155,7 @@ let join_array rs = let debuginfo_op = function | Capply(_, dbg) -> dbg | Cextcall(_, _, _, dbg) -> dbg - | Craise dbg -> dbg + | Craise (_, dbg) -> dbg | Ccheckbound dbg -> dbg | _ -> Debuginfo.none @@ -177,6 +179,7 @@ class virtual selector_generic = object (self) method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true + | Cconst_blockheader _ -> true | Cconst_float _ -> true | Cconst_symbol _ -> true | Cconst_pointer _ -> true @@ -206,8 +209,39 @@ method virtual select_addressing : (* Default instruction selection for stores (of words) *) -method select_store addr arg = - (Istore(Word, addr), arg) +method select_store is_assign addr arg = + (Istore(Word, addr, is_assign), arg) + +(* call marking methods, documented in selectgen.mli *) + +method mark_call = + Proc.contains_calls := true + +method mark_tailcall = () + +method mark_c_tailcall = () + +method mark_instr = function + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + self#mark_call + | Iop (Itailcall_ind | Itailcall_imm _) -> + self#mark_tailcall + | Iop (Ialloc _) -> + self#mark_call (* caml_alloc*, caml_garbage_collection *) + | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) -> + self#mark_c_tailcall (* caml_ml_array_bound_error *) + | Iraise raise_kind -> + begin match raise_kind with + | Lambda.Raise_notrace -> () + | Lambda.Raise_regular | Lambda.Raise_reraise -> + if !Clflags.debug then (* PR#6239 *) + (* caml_stash_backtrace; we #mark_call rather than + #mark_c_tailcall to get a good stack backtrace *) + self#mark_call + end + | Itrywith _ -> + self#mark_call + | _ -> () (* Default instruction selection for operators *) @@ -222,28 +256,19 @@ method select_operation op args = | (Cstore chunk, [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin - let (op, newarg2) = self#select_store addr arg2 in + let (op, newarg2) = self#select_store true addr arg2 in (op, [newarg2; eloc]) end else begin - (Istore(chunk, addr), [arg2; eloc]) + (Istore(chunk, addr, true), [arg2; eloc]) (* Inversion addr/datum in Istore *) end | (Calloc, _) -> (Ialloc 0, args) | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args - | (Cmuli, [arg1; Cconst_int n]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args - | (Cmuli, [Cconst_int n; arg1]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args | (Cmuli, _) -> self#select_arith_comm Imul args - | (Cdivi, _) -> self#select_arith Idiv args - | (Cmodi, _) -> self#select_arith_comm Imod args + | (Cmulhi, _) -> self#select_arith_comm Imulh args + | (Cdivi, _) -> (Iintop Idiv, args) + | (Cmodi, _) -> (Iintop Imod, args) | (Cand, _) -> self#select_arith_comm Iand args | (Cor, _) -> self#select_arith_comm Ior args | (Cxor, _) -> self#select_arith_comm Ixor args @@ -400,6 +425,9 @@ method emit_expr env exp = | Cconst_natint n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int n) [||] r) + | Cconst_blockheader n -> + let r = self#regs_for typ_int in + Some(self#insert_op (Iconst_blockheader n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in Some(self#insert_op (Iconst_float n) [||] r) @@ -441,13 +469,13 @@ method emit_expr env exp = | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end - | Cop(Craise dbg, [arg]) -> + | Cop(Craise (k, dbg), [arg]) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; - self#insert_debug Iraise dbg rd [||]; + self#insert_debug (Iraise k) dbg rd [||]; None end | Cop(Ccmpf comp, args) -> @@ -461,7 +489,6 @@ method emit_expr env exp = let dbg = debuginfo_op op in match new_op with Icall_ind -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in @@ -473,7 +500,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Icall_imm lbl -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in @@ -483,7 +509,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> - Proc.contains_calls := true; let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in @@ -492,7 +517,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> - Proc.contains_calls := true; let rd = self#regs_for typ_addr in let size = size_expr env (Ctuple new_args) in self#insert (Iop(Ialloc size)) [||] rd; @@ -567,7 +591,6 @@ method emit_expr env exp = None end | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in @@ -654,16 +677,16 @@ method emit_stores env data regs_addr = ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> - let (op, arg) = self#select_store !a e in + let (op, arg) = self#select_store false !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with - Istore(_, _) -> + Istore(_, _, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word in - self#insert (Iop(Istore(kind, !a))) + self#insert (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done @@ -704,7 +727,6 @@ method emit_tail env exp = self#insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; @@ -724,7 +746,6 @@ method emit_tail env exp = self#insert_moves r1 loc_arg'; self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; @@ -774,7 +795,6 @@ method emit_tail env exp = let s2 = self#emit_tail_sequence new_env e2 in self#insert (Icatch(nfail, s1, s2)) [||] [||] | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (opt_r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in @@ -814,9 +834,11 @@ method emit_fundecl f = f.Cmm.fun_args rargs Tbl.empty in self#insert_moves loc_arg rarg; self#emit_tail env f.Cmm.fun_body; + let body = self#extract in + instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; - fun_body = self#extract; + fun_body = body; fun_fast = f.Cmm.fun_fast; fun_dbg = f.Cmm.fun_dbg } @@ -835,3 +857,7 @@ let is_tail_call nargs = let _ = Simplif.is_tail_native_heuristic := is_tail_call + +let reset () = + catch_regs := []; + current_function_name := "" diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 11af7c1f..0de90382 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -35,7 +35,8 @@ class virtual selector_generic : object method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : - Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + bool -> Arch.addressing_mode -> Cmm.expression -> + Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. @@ -58,6 +59,30 @@ class virtual selector_generic : object (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) + method mark_call : unit + (* informs the code emitter that the current function is non-leaf: + it may perform a (non-tail) call; by default, sets + [Proc.contains_calls := true] *) + + method mark_tailcall : unit + (* informs the code emitter that the current function may end with + a tail-call; by default, does nothing *) + + method mark_c_tailcall : unit + (* informs the code emitter that the current function may call + a C function that never returns; by default, does nothing. + + It is unecessary to save the stack pointer in this situation + (which is the main purpose of tracking leaf functions) but some + architectures still need to ensure that the stack is properly + aligned when the C function is called. This is achieved by + overloading this method to set [Proc.contains_calls := true] *) + + method mark_instr : Mach.instruction_desc -> unit + (* dispatches on instructions to call one of the marking function + above; overloading this is useful if Ispecific instructions need + marking *) + (* The following method is the entry point and should not be overridden *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl @@ -76,3 +101,5 @@ class virtual selector_generic : object (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit end + +val reset : unit -> unit diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml new file mode 100644 index 00000000..e48d6043 --- /dev/null +++ b/asmcomp/sparc/CSE.ml @@ -0,0 +1,30 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for Sparc *) + +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic (* as super *) + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index b8387cd7..877a3d52 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -64,7 +64,7 @@ let symbol_prefix = if Config.system = "sunos" then "_" else "" let emit_symbol s = - if String.length s >= 1 & s.[0] = '.' + if String.length s >= 1 && s.[0] = '.' then emit_string s else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end @@ -190,7 +190,7 @@ let emit_frame fd = (* Record floating-point constants *) -let float_constants = ref ([] : (int * string) list) +let float_constants = ref ([] : (int * int64) list) let emit_float_constant (lbl, cst) = rodata (); @@ -302,18 +302,18 @@ let rec emit_instr i dslot = | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` else begin ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + float_constants := (lbl, Int64.bits_of_float f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> @@ -375,7 +375,7 @@ let rec emit_instr i dslot = | _ -> "ld" in emit_load loadinstr addr i.arg dest end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let src = i.arg.(0) in begin match chunk with Double_u -> @@ -443,36 +443,15 @@ let rec emit_instr i dslot = ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; ` wr %g1, %y\n`; ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` smul {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Ilsl, 1)) -> (* UltraSPARC has two add units but only one shifter. *) ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - if n = 1 lsl l then begin - let lbl = new_label() in - ` cmp {emit_reg i.arg.(0)}, 0\n`; - ` bge {emit_label lbl}\n`; - ` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *) - ` add %g1, {emit_int (n-1)}, %g1\n`; - `{emit_label lbl}:\n`; - ` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n` - end else begin - ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; - ` wr %g1, %y\n`; - ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let lbl = new_label() in - ` tst {emit_reg i.arg.(0)}\n`; - ` bge {emit_label lbl}\n`; - ` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *) - ` be {emit_label lbl}\n`; - ` nop\n`; - ` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; - `{emit_label lbl}:\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if !arch_version = SPARC_V9 then begin @@ -496,6 +475,9 @@ let rec emit_instr i dslot = ` bleu {emit_label !range_check_trap}\n`; ` nop\n` (* delay slot *) end + | Lop(Iintop_imm(Imulh, n)) -> + ` smul {emit_reg i.arg.(0)}, {emit_int n}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` @@ -603,7 +585,7 @@ let rec emit_instr i dslot = ` ld [%sp + 100], %l5\n`; ` add %sp, 8, %sp\n`; stack_offset := !stack_offset - 8 - | Lraise -> + | Lraise _ -> ` ld [%l5 + 96], %g1\n`; ` mov %l5, %sp\n`; ` ld [%sp + 100], %l5\n`; @@ -618,7 +600,7 @@ and fill_delay_slot = function that does not branch. *) let is_one_instr_op = function - Idiv | Imod | Icomp _ | Icheckbound -> false + Imulh | Idiv | Imod | Icomp _ | Icheckbound -> false | _ -> true let is_one_instr i = @@ -627,10 +609,10 @@ let is_one_instr i = begin match op with Imove | Ispill | Ireload -> i.arg.(0).typ <> Float && i.res.(0).typ <> Float - | Iconst_int n -> is_native_immediate n + | Iconst_int n | Iconst_blockheader n -> is_native_immediate n | Istackoffset _ -> true - | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n + | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true @@ -660,15 +642,15 @@ let rec emit_all i = emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Itailcall_imm s)}} - when s = !function_name & is_one_instr i -> + when s = !function_name && is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Icall_ind)}} - when is_one_instr i & no_interference i.res i.next.arg -> + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lcondbranch(_, _)}} - when is_one_instr i & no_interference i.res i.next.arg -> + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> @@ -724,9 +706,9 @@ let emit_item = function | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".word" f + emit_float32_directive ".word" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".word" f + emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index ed107a82..625f517f 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -81,12 +81,12 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 19 Reg.dummy in + let v = Array.make 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v @@ -105,7 +105,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -171,6 +171,10 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 (* $o0 *) +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) @@ -196,6 +200,15 @@ let max_register_pressure = function Iextcall(_, _) -> [| 11; 0 |] | _ -> [| 19; 15 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index 048880ab..497722bb 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -47,8 +47,6 @@ method oper_issue_cycles = function | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 5 - | Iintop_imm(Imod, _) -> 5 | Iintop_imm(Icomp _, _) -> 4 | Iintop_imm(Icheckbound, _) -> 2 | Inegf -> 2 diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 055b78f1..d938c1ef 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -38,23 +38,13 @@ method select_addressing chunk = function method! select_operation op args = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into - calls to C library routines, except if the dividend is a power of 2. + calls to C library routines. For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) - (Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, _) when !arch_version = SPARC_V7 -> + (Cmuli, _) when !arch_version = SPARC_V7 -> (Iextcall(".umul", false), args) - | (Cdivi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) | (Cdivi, _) when !arch_version = SPARC_V7 -> (Iextcall(".div", false), args) - | (Cmodi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) | (Cmodi, _) -> (Iextcall(".rem", false), args) | _ -> diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index f52b09fc..105550d0 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -40,7 +40,7 @@ let spill_reg r = with Not_found -> let spill_r = Reg.create r.typ in spill_r.spill <- true; - if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; + if not (Reg.anonymous r) then spill_r.raw_name <- r.raw_name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r @@ -64,7 +64,7 @@ let add_superpressure_regs op live_regs res_regs spilled = let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) - let pressure = Array.create Proc.num_register_classes 0 in + let pressure = Array.make Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin @@ -233,12 +233,17 @@ let rec reload i before = (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in - let (new_handler, after_handler) = reload handler handler.live in + (* All registers live at the beginning of the handler are destroyed, + except the exception bucket *) + let before_handler = + Reg.Set.remove Proc.loc_exn_bucket + (Reg.add_set_array handler.live handler.arg) in + let (new_handler, after_handler) = reload handler before_handler in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, finally) - | Iraise -> + | Iraise _ -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) (* Second pass: add spill instructions based on what we've decided to reload. @@ -379,15 +384,19 @@ let rec spill i finally = spill_at_raise := saved_spill_at_raise; (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, before_body) - | Iraise -> + | Iraise _ -> (i, !spill_at_raise) (* Entry point *) -let fundecl f = +let reset () = spill_env := Reg.Map.empty; use_date := Reg.Map.empty; - current_date := 0; + current_date := 0 + +let fundecl f = + reset (); + let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli index 66954aef..598a1755 100644 --- a/asmcomp/spill.mli +++ b/asmcomp/spill.mli @@ -14,3 +14,4 @@ before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl +val reset : unit -> unit diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 96e9e376..8c553ab9 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -30,7 +30,7 @@ let subst_regs rv sub = None -> rv | Some s -> let n = Array.length rv in - let nv = Array.create n Reg.dummy in + let nv = Array.make n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv @@ -184,8 +184,8 @@ let rec rename i sub = rename i.next (merge_substs sub_body sub_handler i.next) in (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) - | Iraise -> - (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, + | Iraise k -> + (instr_cons_debug (Iraise k) (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) @@ -195,8 +195,13 @@ let set_repres i = (* Entry point *) -let fundecl f = +let reset () = equiv_classes := Reg.Map.empty; + exit_subst := [] + +let fundecl f = + reset (); + let new_args = Array.copy f.fun_args in let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; diff --git a/asmcomp/split.mli b/asmcomp/split.mli index f794fec1..1924a5ad 100644 --- a/asmcomp/split.mli +++ b/asmcomp/split.mli @@ -13,3 +13,5 @@ (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl + +val reset : unit -> unit diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml new file mode 100644 index 00000000..d63e92bf --- /dev/null +++ b/asmcomp/strmatch.ml @@ -0,0 +1,389 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +open Lambda +open Cmm + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) = struct + +(* Debug *) + + let dbg = false + + let mask = + let open Nativeint in + sub (shift_left one 8) one + + let pat_as_string p = + let rec digits k n p = + if n <= 0 then k + else + let d = Nativeint.to_int (Nativeint.logand mask p) in + let d = Char.escaped (Char.chr d) in + digits (d::k) (n-1) (Nativeint.shift_right_logical p 8) in + let ds = digits [] Arch.size_addr p in + let ds = + if Arch.big_endian then ds else List.rev ds in + String.concat "" ds + + let do_pp_cases chan cases = + List.iter + (fun (ps,_) -> + Printf.fprintf chan " [%s]\n" + (String.concat "; " (List.map pat_as_string ps))) + cases + + let pp_cases chan tag cases = + Printf.eprintf "%s:\n" tag ; + do_pp_cases chan cases + + let pp_match chan tag idxs cases = + Printf.eprintf + "%s: idx=[%s]\n" tag + (String.concat "; " (List.map string_of_int idxs)) ; + do_pp_cases chan cases + +(* Utilities *) + + let gen_cell_id () = Ident.create "cell" + let gen_size_id () = Ident.create "size" + + let mk_let_cell id str ind body = + let cell = + Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in + Clet(id, cell, body) + + let mk_let_size id str body = + let size = I.string_block_length str in + Clet(id, size, body) + + let mk_cmp_gen cmp_op id nat ifso ifnot = + let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in + Cifthenelse (test, ifso, ifnot) + + let mk_lt = mk_cmp_gen Clt + let mk_eq = mk_cmp_gen Ceq + + module IntArg = + struct + type t = int + let compare (x:int) (y:int) = + if x < y then -1 + else if x > y then 1 + else 0 + end + + let interval m0 n = + let rec do_rec m = + if m >= n then [] + else m::do_rec (m+1) in + do_rec m0 + + +(*****************************************************) +(* Compile strings to a lists of words [native ints] *) +(*****************************************************) + + let pat_of_string str = + let len = String.length str in + let n = len / Arch.size_addr + 1 in + let get_byte i = + if i < len then int_of_char str.[i] + else if i < n * Arch.size_addr - 1 then 0 + else n * Arch.size_addr - 1 - len in + let mk_word ind = + let w = ref 0n in + let imin = ind * Arch.size_addr + and imax = (ind + 1) * Arch.size_addr - 1 in + if Arch.big_endian then + for i = imin to imax do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done + else + for i = imax downto imin do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done; + !w in + let rec mk_words ind = + if ind >= n then [] + else mk_word ind::mk_words (ind+1) in + mk_words 0 + +(*****************************) +(* Discriminating heuristics *) +(*****************************) + + module IntSet = Set.Make(IntArg) + module NativeSet = Set.Make(Nativeint) + + let rec add_one sets ps = match sets,ps with + | [],[] -> [] + | set::sets,p::ps -> + let sets = add_one sets ps in + NativeSet.add p set::sets + | _,_ -> assert false + + let count_arities cases = match cases with + | [] -> assert false + | (ps,_)::_ -> + let sets = + List.fold_left + (fun sets (ps,_) -> add_one sets ps) + (List.map (fun _ -> NativeSet.empty) ps) cases in + List.map NativeSet.cardinal sets + + let count_arities_first cases = + let set = + List.fold_left + (fun set case -> match case with + | (p::_,_) -> NativeSet.add p set + | _ -> assert false) + NativeSet.empty cases in + NativeSet.cardinal set + + let count_arities_length cases = + let set = + List.fold_left + (fun set (ps,_) -> IntSet.add (List.length ps) set) + IntSet.empty cases in + IntSet.cardinal set + + let best_col = + let rec do_rec kbest best k = function + | [] -> kbest + | x::xs -> + if x < best then + do_rec k x (k+1) xs + else + do_rec kbest best (k+1) xs in + let smallest = do_rec (-1) max_int 0 in + fun cases -> + let ars = count_arities cases in + smallest ars + + let swap_list = + let rec do_rec k xs = match xs with + | [] -> assert false + | x::xs -> + if k <= 0 then [],x,xs + else + let xs,mid,ys = do_rec (k-1) xs in + x::xs,mid,ys in + fun k xs -> + let xs,x,ys = do_rec k xs in + x::xs @ ys + + let swap k idxs cases = + if k = 0 then idxs,cases + else + let idxs = swap_list k idxs + and cases = + List.map + (fun (ps,act) -> swap_list k ps,act) + cases in + if dbg then begin + pp_match stderr "SWAP" idxs cases + end ; + idxs,cases + + let best_first idxs cases = match idxs with + | []|[_] -> idxs,cases (* optimisation: one column only *) + | _ -> + let k = best_col cases in + swap k idxs cases + +(************************************) +(* Divide according to first column *) +(************************************) + + module Divide(O:Set.OrderedType) = struct + + module OMap = Map.Make(O) + + let do_find key env = + try OMap.find key env + with Not_found -> assert false + + let divide cases = + let env = + List.fold_left + (fun env (p,psact) -> + let old = + try OMap.find p env + with Not_found -> [] in + OMap.add p ((psact)::old) env) + OMap.empty cases in + let r = OMap.fold (fun key v k -> (key,v)::k) env [] in + List.rev r (* Now sorted *) + end + +(***************) +(* Compilation *) +(***************) + +(* Group by cell *) + + module DivideNative = Divide(Nativeint) + + let by_cell cases = + DivideNative.divide + (List.map + (fun case -> match case with + | (p::ps),act -> p,(ps,act) + | [],_ -> assert false) + cases) + +(* Split into two halves *) + + let rec do_split idx env = match env with + | [] -> assert false + | (midkey,_ as x)::rem -> + if idx <= 0 then [],midkey,env + else + let lt,midkey,ge = do_split (idx-1) rem in + x::lt,midkey,ge + + let split_env len env = do_split (len/2) env + +(* Switch according to one cell *) + +(* + Emit the switch, here as a comparison tree. + Argument compile_rec is to be called to compile the rest of patterns, + as match_on_cell can be called in two different contexts : + from do_compile_pats and top_compile below. + *) + let match_oncell compile_rec str default idx env = + let id = gen_cell_id () in + let rec comp_rec env = + let len = List.length env in + if len <= 3 then + List.fold_right + (fun (key,cases) ifnot -> + mk_eq id key + (compile_rec str default cases) + ifnot) + env default + else + let lt,midkey,ge = split_env len env in + mk_lt id midkey (comp_rec lt) (comp_rec ge) in + mk_let_cell id str idx (comp_rec env) + +(* + Recursive 'list of cells' compile function: + - choose the matched cell and switch on it + - notice: patterns (and idx) all have the same length + *) + + let rec do_compile_pats idxs str default cases = + if dbg then begin + pp_match stderr "COMPILE" idxs cases + end ; + match idxs with + | [] -> + begin match cases with + | [] -> default + | (_,e)::_ -> e + end + | _::_ -> + let idxs,cases = best_first idxs cases in + begin match idxs with + | [] -> assert false + | idx::idxs -> + match_oncell + (do_compile_pats idxs) str default idx (by_cell cases) + end + + +(* Group by size *) + + module DivideInt = Divide(IntArg) + + + let by_size cases = + DivideInt.divide + (List.map + (fun (ps,_ as case) -> List.length ps,case) + cases) +(* + Switch according to pattern size + Argument from_ind is the starting index, it can be zero + or one (when the swicth on the cell 0 has already been performed. + In that latter case pattern len is string length-1 and is corrected. + *) + + let compile_by_size from_ind str default cases = + let size_cases = + List.map + (fun (len,cases) -> + let len = len+from_ind in + let act = + do_compile_pats + (interval from_ind len) + str default cases in + (len,act)) + (by_size cases) in + let id = gen_size_id () in + let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in + mk_let_size id str switch + +(* + Compilation entry point: we choose to switch + either on size or on first cell, using the + 'least discriminant' heuristics. + *) + let top_compile str default cases = + let a_len = count_arities_length cases + and a_fst = count_arities_first cases in + if a_len <= a_fst then begin + if dbg then pp_cases stderr "SIZE" cases ; + compile_by_size 0 str default cases + end else begin + if dbg then pp_cases stderr "FIRST COL" cases ; + let compile_size_rest str default cases = + compile_by_size 1 str default cases in + match_oncell compile_size_rest str default 0 (by_cell cases) + end + +(* Module entry point *) + + let catch arg k = match arg with + | Cexit (e,[]) -> k arg + | _ -> + let e = next_raise_count () in + Ccatch (e,[],k (Cexit (e,[])),arg) + + let compile str default cases = +(* We do not attempt to really optimise default=None *) + let cases,default = match cases,default with + | (_,e)::cases,None + | cases,Some e -> cases,e + | [],None -> assert false in + let cases = + List.rev_map + (fun (s,act) -> pat_of_string s,act) + cases in + catch default (fun default -> top_compile str default cases) + + end diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli new file mode 100644 index 00000000..143dae5c --- /dev/null +++ b/asmcomp/strmatch.mli @@ -0,0 +1,28 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) : sig + (* Compile stringswitch (arg,cases,d) + Note: cases should not contain string duplicates *) + val compile : Cmm.expression (* arg *) -> Cmm.expression option (* d *) -> + (string * Cmm.expression) list (* cases *)-> Cmm.expression +end diff --git a/asmrun/.depend b/asmrun/.depend index c8e6f5c7..1088ad8e 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -60,7 +60,8 @@ fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ @@ -97,7 +98,7 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -110,7 +111,7 @@ ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -226,8 +227,7 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -311,7 +311,8 @@ fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ @@ -348,7 +349,7 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -361,7 +362,7 @@ ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -477,8 +478,7 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -562,7 +562,8 @@ fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ @@ -599,7 +600,7 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -612,7 +613,7 @@ ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -728,8 +729,7 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ diff --git a/asmrun/Makefile b/asmrun/Makefile index 5ebf7aad..63ff80c6 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -24,8 +24,8 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ - meta.o dynlink.o + compact.o finalise.o custom.o $(UNIX_OR_WIN32).o backtrace.o natdynlink.o\ + debugger.o meta.o dynlink.o ASMOBJS=$(ARCH).o @@ -60,26 +60,29 @@ libasmrunp.a: $(POBJS) ar rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: install-default install-$(RUNTIMED) install-$(PROFILING) install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a + cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp libasmrund.a $(LIBDIR)/libasmrund.a - cd $(LIBDIR); $(RANLIB) libasmrund.a + cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a .PHONY: install-runtimed install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a + rm -f $(INSTALL_LIBDIR)/libasmrunp.a + ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a power-bsd_elf.S: power-elf.S cp power-elf.S power-bsd_elf.S @@ -152,8 +155,8 @@ meta.c: ../byterun/meta.c ln -s ../byterun/meta.c meta.c globroots.c: ../byterun/globroots.c ln -s ../byterun/globroots.c globroots.c -unix.c: ../byterun/unix.c - ln -s ../byterun/unix.c unix.c +$(UNIX_OR_WIN32).c: ../byterun/$(UNIX_OR_WIN32).c + ln -s ../byterun/$(UNIX_OR_WIN32).c $(UNIX_OR_WIN32).c dynlink.c: ../byterun/dynlink.c ln -s ../byterun/dynlink.c dynlink.c signals.c: ../byterun/signals.c @@ -164,8 +167,8 @@ debugger.c: ../byterun/debugger.c LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ - dynlink.c signals.c debugger.c + weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \ + $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c clean:: rm -f $(LINKEDFILES) @@ -180,7 +183,7 @@ clean:: exit 2; } .S.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: ln -s -f $*.c $*.d.c diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 876fe602..77c2002d 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -56,8 +56,10 @@ i386.o: i386.S amd64.o: amd64.S $(ASPP) -DSYS_$(SYSTEM) amd64.S +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: - cp libasmrun.$(A) $(LIBDIR) + cp libasmrun.$(A) $(INSTALL_LIBDIR) $(LINKEDFILES): %.c: ../byterun/%.c cp ../byterun/$*.c $*.c diff --git a/asmrun/amd64.S b/asmrun/amd64.S index aed5a964..d2e00752 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -32,7 +32,7 @@ .align FUNCTION_ALIGN; \ name: -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) #define LBL(x) .L##x #define G(r) r @@ -90,7 +90,7 @@ #endif -#if defined(__PIC__) && !defined(SYS_mingw64) +#if defined(__PIC__) && !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Position-independent operations on global variables. */ @@ -99,6 +99,10 @@ movq GREL(dstlabel)(%rip), %r11 ; \ movq srcreg, (%r11) +#define STORE_VAR32(srcreg,dstlabel) \ + movq GREL(dstlabel)(%rip), %r11 ; \ + movl srcreg, (%r11) + /* Load global [srclabel] in register [dstreg]. Clobbers %r11. */ #define LOAD_VAR(srclabel,dstreg) \ movq GREL(srclabel)(%rip), %r11 ; \ @@ -144,6 +148,9 @@ #define STORE_VAR(srcreg,dstlabel) \ movq srcreg, G(dstlabel)(%rip) +#define STORE_VAR32(srcreg,dstlabel) \ + movl srcreg, G(dstlabel)(%rip) + #define LOAD_VAR(srclabel,dstreg) \ movq G(srclabel)(%rip), dstreg @@ -172,7 +179,7 @@ /* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ -#if defined(SYS_mingw64) +#if defined(SYS_mingw64) || defined(SYS_cygwin) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ @@ -242,7 +249,7 @@ #endif -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined (SYS_cygwin) /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ # define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) # define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) @@ -264,7 +271,7 @@ FUNCTION(G(caml_call_gc)) CFI_STARTPROC RECORD_STACK_FRAME(0) LBL(caml_call_gc): -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -441,7 +448,7 @@ LBL(caml_c_call): STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -510,7 +517,7 @@ CFI_ENDPROC /* Registers holding arguments of C functions. */ -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined(SYS_cygwin) #define C_ARG_1 %rcx #define C_ARG_2 %rdx #define C_ARG_3 %r8 @@ -532,6 +539,8 @@ CFI_STARTPROC popq %r14 ret LBL(110): + STORE_VAR32($0, caml_backtrace_pos) +LBL(111): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ #ifdef WITH_FRAME_POINTERS @@ -553,18 +562,27 @@ LBL(110): ret CFI_ENDPROC +FUNCTION(G(caml_reraise_exn)) +CFI_STARTPROC + TESTL_VAR($1, caml_backtrace_active) + jne LBL(111) + movq %r14, %rsp + popq %r14 + ret +CFI_ENDPROC + /* Raise an exception from C */ FUNCTION(G(caml_raise_exception)) CFI_STARTPROC TESTL_VAR($1, caml_backtrace_active) - jne LBL(111) + jne LBL(112) movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret -LBL(111): +LBL(112): #ifdef WITH_FRAME_POINTERS ENTER_FUNCTION ; #endif @@ -592,7 +610,7 @@ CFI_ENDPROC backtrace anyway. */ FUNCTION(G(caml_stack_overflow)) - LEA_VAR(caml_bucket_Stack_overflow, %rax) + LEA_VAR(caml_exn_Stack_overflow, %rax) movq %r14, %rsp /* cut the stack */ popq %r14 /* recover previous exn handler */ ret /* jump to handler's code */ @@ -656,7 +674,7 @@ G(caml_system__frametable): #if defined(SYS_macosx) .literal16 -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) .section .rdata,"dr" #else .section .rodata.cst8,"a",@progbits diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index e86ee72c..4883ba97 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -29,6 +29,7 @@ EXTRN caml_last_return_address: QWORD EXTRN caml_gc_regs: QWORD EXTRN caml_exception_pointer: QWORD + EXTRN caml_backtrace_pos: DWORD EXTRN caml_backtrace_active: DWORD EXTRN caml_stash_backtrace: NEAR @@ -306,6 +307,8 @@ caml_raise_exn: pop r14 ; Recover previous exception handler ret ; Branch to handler L110: + mov caml_backtrace_pos, 0 +L111: mov r12, rax ; Save exception bucket in r12 mov rcx, rax ; Arg 1: exception bucket mov rdx, [rsp] ; Arg 2: PC of raise @@ -318,19 +321,28 @@ L110: pop r14 ; Recover previous exception handler ret ; Branch to handler + PUBLIC caml_reraise_exn + ALIGN 16 +caml_reraise_exn: + test caml_backtrace_active, 1 + jne L111 + mov rsp, r14 ; Cut stack + pop r14 ; Recover previous exception handler + ret ; Branch to handler + ; Raise an exception from C PUBLIC caml_raise_exception ALIGN 16 caml_raise_exception: test caml_backtrace_active, 1 - jne L111 + jne L112 mov rax, rcx ; First argument is exn bucket mov rsp, caml_exception_pointer pop r14 ; Recover previous exception handler mov r15, caml_young_ptr ; Reload alloc ptr ret -L111: +L112: mov r12, rcx ; Save exception bucket in r12 ; Arg 1: exception bucket mov rdx, caml_last_return_address ; Arg 2: PC of raise diff --git a/asmrun/arm.S b/asmrun/arm.S index 2ce244a1..9720665a 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -44,6 +44,15 @@ cmp \reg, #0 beq \lbl .endm +#elif defined(SYS_freebsd) + .arch armv6 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm #endif trap_ptr .req r8 diff --git a/asmrun/arm64.S b/asmrun/arm64.S new file mode 100644 index 00000000..9b4b9ab7 --- /dev/null +++ b/asmrun/arm64.S @@ -0,0 +1,551 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2013 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Asm part of the runtime system, ARM processor, 64-bit mode */ +/* Must be preprocessed by cpp */ + +/* Special registers */ + +#define TRAP_PTR x26 +#define ALLOC_PTR x27 +#define ALLOC_LIMIT x28 +#define ARG x15 +#define TMP x16 +#define TMP2 x17 + +/* Support for CFI directives */ + +#if defined(ASM_CFI_SUPPORTED) +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + +/* Support for profiling with gprof */ + +#define PROFILE + +/* Macros to load and store global variables. Destroy TMP2 */ + +#if defined(__PIC__) + +#define ADDRGLOBAL(reg,symb) \ + adrp TMP2, :got:symb; \ + ldr reg, [TMP2, #:got_lo12:symb] + +#define LOADGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + ldr reg, [TMP2] + +#define STOREGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + str reg, [TMP2] + +#else + +#define ADDRGLOBAL(reg,symb) \ + adrp reg, symb; \ + add reg, reg, #:lo12:symb + +#define LOADGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + ldr reg, [TMP2, #:lo12:symb] + +#define STOREGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + str reg, [TMP2, #:lo12:symb] + +#endif + +/* Allocation functions and GC interface */ + + .globl caml_system__code_begin +caml_system__code_begin: + + .align 2 + .globl caml_call_gc +caml_call_gc: + CFI_STARTPROC + PROFILE + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Record lowest stack address */ + mov TMP, sp + STOREGLOBAL(TMP, caml_bottom_of_stack) +.Lcaml_call_gc: + /* Set up stack space, saving return address and frame pointer */ + /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ + stp x29, x30, [sp, -400]! + CFI_ADJUST(400) + add x29, sp, #0 + /* Save allocatable integer registers on the stack, in the order + given in proc.ml */ + stp x0, x1, [sp, 16] + stp x2, x3, [sp, 32] + stp x4, x5, [sp, 48] + stp x6, x7, [sp, 64] + stp x8, x9, [sp, 80] + stp x10, x11, [sp, 96] + stp x12, x13, [sp, 112] + stp x14, x15, [sp, 128] + stp x19, x20, [sp, 144] + stp x21, x22, [sp, 160] + stp x23, x24, [sp, 176] + str x25, [sp, 192] + /* Save caller-save floating-point registers on the stack + (callee-saves are preserved by caml_garbage_collection) */ + stp d0, d1, [sp, 208] + stp d2, d3, [sp, 224] + stp d4, d5, [sp, 240] + stp d6, d7, [sp, 256] + stp d16, d17, [sp, 272] + stp d18, d19, [sp, 288] + stp d20, d21, [sp, 304] + stp d22, d23, [sp, 320] + stp d24, d25, [sp, 336] + stp d26, d27, [sp, 352] + stp d28, d29, [sp, 368] + stp d30, d31, [sp, 384] + /* Store pointer to saved integer registers in caml_gc_regs */ + add TMP, sp, #16 + STOREGLOBAL(TMP, caml_gc_regs) + /* Save current allocation pointer for debugging purposes */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Save trap pointer in case an exception is raised during GC */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the garbage collector */ + bl caml_garbage_collection + /* Restore registers */ + ldp x0, x1, [sp, 16] + ldp x2, x3, [sp, 32] + ldp x4, x5, [sp, 48] + ldp x6, x7, [sp, 64] + ldp x8, x9, [sp, 80] + ldp x10, x11, [sp, 96] + ldp x12, x13, [sp, 112] + ldp x14, x15, [sp, 128] + ldp x19, x20, [sp, 144] + ldp x21, x22, [sp, 160] + ldp x23, x24, [sp, 176] + ldr x25, [sp, 192] + ldp d0, d1, [sp, 208] + ldp d2, d3, [sp, 224] + ldp d4, d5, [sp, 240] + ldp d6, d7, [sp, 256] + ldp d16, d17, [sp, 272] + ldp d18, d19, [sp, 288] + ldp d20, d21, [sp, 304] + ldp d22, d23, [sp, 320] + ldp d24, d25, [sp, 336] + ldp d26, d27, [sp, 352] + ldp d28, d29, [sp, 368] + ldp d30, d31, [sp, 384] + /* Reload new allocation pointer and allocation limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Free stack space and return to caller */ + ldp x29, x30, [sp], 400 + ret + CFI_ENDPROC + .type caml_call_gc, %function + .size caml_call_gc, .-caml_call_gc + + .align 2 + .globl caml_alloc1 +caml_alloc1: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #16 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. This is the address + immediately above the pair of words (x29 and x30) we just pushed. Those must + not be included since otherwise the distance from [caml_bottom_of_stack] to the + highest address in the caller's stack frame won't match the frame size contained + in the relevant frame descriptor. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc1, %function + .size caml_alloc1, .-caml_alloc1 + + .align 2 + .globl caml_alloc2 +caml_alloc2: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #24 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 + + .align 2 + .globl caml_alloc3 +caml_alloc3: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #32 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 + + .align 2 + .globl caml_allocN +caml_allocN: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, ARG + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC. This preserves ARG */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_allocN, %function + .size caml_allocN, .-caml_allocN + +/* Call a C function from OCaml */ +/* Function to call is in ARG */ + + .align 2 + .globl caml_c_call +caml_c_call: + CFI_STARTPROC + PROFILE + /* Preserve return address in callee-save register x19 */ + mov x19, x30 + /* Record lowest stack address and return address */ + STOREGLOBAL(x30, caml_last_return_address) + add TMP, sp, #0 + STOREGLOBAL(TMP, caml_bottom_of_stack) + /* Make the exception handler alloc ptr available to the C code */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the function */ + blr ARG + /* Reload alloc ptr and alloc limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Return */ + ret x19 + CFI_ENDPROC + .type caml_c_call, %function + .size caml_c_call, .-caml_c_call + +/* Start the OCaml program */ + + .align 2 + .globl caml_start_program +caml_start_program: + CFI_STARTPROC + PROFILE + ADDRGLOBAL(ARG, caml_program) + +/* Code shared with caml_callback* */ +/* Address of OCaml code to call is in ARG */ +/* Arguments to the OCaml code are in x0...x7 */ + +.Ljump_to_caml: + /* Set up stack frame and save callee-save registers */ + stp x29, x30, [sp, -160]! + CFI_ADJUST(160) + add x29, sp, #0 + stp x19, x20, [sp, 16] + stp x21, x22, [sp, 32] + stp x23, x24, [sp, 48] + stp x25, x26, [sp, 64] + stp x27, x28, [sp, 80] + stp d8, d9, [sp, 96] + stp d10, d11, [sp, 112] + stp d12, d13, [sp, 128] + stp d14, d15, [sp, 144] + /* Setup a callback link on the stack */ + LOADGLOBAL(x8, caml_bottom_of_stack) + LOADGLOBAL(x9, caml_last_return_address) + LOADGLOBAL(x10, caml_gc_regs) + stp x8, x9, [sp, -32]! /* 16-byte alignment */ + CFI_ADJUST(32) + str x10, [sp, 16] + /* Setup a trap frame to catch exceptions escaping the OCaml code */ + LOADGLOBAL(x8, caml_exception_pointer) + adr x9, .Ltrap_handler + stp x8, x9, [sp, -16]! + CFI_ADJUST(16) + add TRAP_PTR, sp, #0 + /* Reload allocation pointers */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Call the OCaml code */ + blr ARG +.Lcaml_retaddr: + /* Pop the trap frame, restoring caml_exception_pointer */ + ldr x8, [sp], 16 + CFI_ADJUST(-16) + STOREGLOBAL(x8, caml_exception_pointer) + /* Pop the callback link, restoring the global variables */ +.Lreturn_result: + ldr x10, [sp, 16] + ldp x8, x9, [sp], 32 + CFI_ADJUST(-32) + STOREGLOBAL(x8, caml_bottom_of_stack) + STOREGLOBAL(x9, caml_last_return_address) + STOREGLOBAL(x10, caml_gc_regs) + /* Update allocation pointer */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Reload callee-save registers and return address */ + ldp x19, x20, [sp, 16] + ldp x21, x22, [sp, 32] + ldp x23, x24, [sp, 48] + ldp x25, x26, [sp, 64] + ldp x27, x28, [sp, 80] + ldp d8, d9, [sp, 96] + ldp d10, d11, [sp, 112] + ldp d12, d13, [sp, 128] + ldp d14, d15, [sp, 144] + ldp x29, x30, [sp], 160 + CFI_ADJUST(-160) + /* Return to C caller */ + ret + CFI_ENDPROC + .type .Lcaml_retaddr, %function + .size .Lcaml_retaddr, .-.Lcaml_retaddr + .type caml_start_program, %function + .size caml_start_program, .-caml_start_program + +/* The trap handler */ + + .align 2 +.Ltrap_handler: + CFI_STARTPROC + /* Save exception pointer */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Encode exception bucket as an exception result */ + orr x0, x0, #2 + /* Return it */ + b .Lreturn_result + CFI_ENDPROC + .type .Ltrap_handler, %function + .size .Ltrap_handler, .-.Ltrap_handler + +/* Raise an exception from OCaml */ + + .align 2 + .globl caml_raise_exn +caml_raise_exn: + CFI_STARTPROC + PROFILE + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + mov x1, x30 /* arg2: pc of raise */ + add x2, sp, #0 /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exn, %function + .size caml_raise_exn, .-caml_raise_exn + +/* Raise an exception from C */ + + .align 2 + .globl caml_raise_exception +caml_raise_exception: + CFI_STARTPROC + PROFILE + /* Reload trap ptr, alloc ptr and alloc limit */ + LOADGLOBAL(TRAP_PTR, caml_exception_pointer) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ + LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exception, %function + .size caml_raise_exception, .-caml_raise_exception + +/* Callback from C to OCaml */ + + .align 2 + .globl caml_callback_exn +caml_callback_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, TMP /* x1 = closure environment */ + ldr ARG, [TMP] /* code pointer */ + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback_exn, %function + .size caml_callback_exn, .-caml_callback_exn + + .align 2 + .globl caml_callback2_exn +caml_callback2_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, TMP /* x2 = closure environment */ + ADDRGLOBAL(ARG, caml_apply2) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback2_exn, %function + .size caml_callback2_exn, .-caml_callback2_exn + + .align 2 + .globl caml_callback3_exn +caml_callback3_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments */ + /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, x3 /* x2 = third arg */ + mov x3, TMP /* x3 = closure environment */ + ADDRGLOBAL(ARG, caml_apply3) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback3_exn, %function + .size caml_callback3_exn, .-caml_callback3_exn + + .align 2 + .globl caml_ml_array_bound_error +caml_ml_array_bound_error: + CFI_STARTPROC + PROFILE + /* Load address of [caml_array_bound_error] in ARG */ + ADDRGLOBAL(ARG, caml_array_bound_error) + /* Call that function */ + b caml_c_call + CFI_ENDPROC + .type caml_ml_array_bound_error, %function + .size caml_ml_array_bound_error, .-caml_ml_array_bound_error + + .globl caml_system__code_end +caml_system__code_end: + +/* GC roots for callback */ + + .data + .align 3 + .globl caml_system__frametable +caml_system__frametable: + .quad 1 /* one descriptor */ + .quad .Lcaml_retaddr /* return address into callback */ + .short -1 /* negative frame size => use callback link */ + .short 0 /* no roots */ + .align 3 + .type caml_system__frametable, %object + .size caml_system__frametable, .-caml_system__frametable diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 3854967c..c72a2373 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -30,6 +30,17 @@ code_t * caml_backtrace_buffer = NULL; value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 +/* In order to prevent the GC from walking through the debug information + (which have no headers), we transform frame_descr pointers into + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as descr pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Descrptr(descr) Val_long((uintnat)descr>>1) +#define Descrptr_Val(v) ((frame_descr *) (Long_val(v)<<1)) + /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) @@ -112,6 +123,7 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -172,7 +184,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { } } - trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); + trace = caml_alloc((mlsize_t) trace_size, 0); /* then collect the trace */ { @@ -183,11 +195,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); Assert(descr != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); - Field(trace, trace_pos) = (value) descr; + Field(trace, trace_pos) = Val_Descrptr(descr); } } @@ -295,31 +303,27 @@ void caml_print_exception_backtrace(void) /* Convert the raw backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) { - CAMLparam1(backtrace); - CAMLlocal4(res, arr, p, fname); - int i; +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); struct loc_info li; - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info((frame_descr *) Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); + extract_location_info(Descrptr_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ - CAMLreturn(res); + + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -328,10 +332,13 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer != NULL) { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) + Field(res, i) = Val_Descrptr(caml_backtrace_buffer[i]); + } CAMLreturn(res); } @@ -348,8 +355,19 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw,res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal4(arr, raw_slot, slot, res); + + arr = caml_alloc(caml_backtrace_pos, 0); + if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); + } else { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) { + raw_slot = Val_Descrptr(caml_backtrace_buffer[i]); + slot = caml_convert_raw_backtrace_slot(raw_slot); + caml_modify(&Field(arr, i), slot); + } + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } diff --git a/asmrun/fail.c b/asmrun/fail.c index 09a9af96..cb2c1cbd 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -13,6 +13,7 @@ /* Raising exceptions from C. */ +#include #include #include "alloc.h" #include "fail.h" @@ -24,6 +25,7 @@ #include "signals.h" #include "stack.h" #include "roots.h" +#include "callback.h" /* The globals holding predefined exceptions */ @@ -42,9 +44,6 @@ extern caml_generated_constant caml_exn_Stack_overflow, caml_exn_Assert_failure, caml_exn_Undefined_recursive_module; -extern caml_generated_constant - caml_bucket_Out_of_memory, - caml_bucket_Stack_overflow; /* Exception raising */ @@ -73,13 +72,7 @@ void caml_raise(value v) void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } void caml_raise_with_arg(value tag, value arg) @@ -111,7 +104,10 @@ void caml_raise_with_args(value tag, int nargs, value args[]) void caml_raise_with_string(value tag, char const *msg) { - caml_raise_with_arg(tag, caml_copy_string(msg)); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); + CAMLnoreturn; } void caml_failwith (char const *msg) @@ -124,22 +120,14 @@ void caml_invalid_argument (char const *msg) caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } -/* To raise [Out_of_memory], we can't use [caml_raise_constant], - because it allocates and we're out of memory... - We therefore use a statically-allocated bucket constructed - by the ocamlopt linker. - This works OK because the exception value for [Out_of_memory] is also - statically allocated out of the heap. - The same applies to Stack_overflow. */ - void caml_raise_out_of_memory(void) { - caml_raise((value) &caml_bucket_Out_of_memory); + caml_raise_constant((value) caml_exn_Out_of_memory); } void caml_raise_stack_overflow(void) { - caml_raise((value) &caml_bucket_Stack_overflow); + caml_raise_constant((value) caml_exn_Stack_overflow); } void caml_raise_sys_error(value msg) @@ -167,43 +155,24 @@ void caml_raise_sys_blocked_io(void) caml_raise_constant((value) caml_exn_Sys_blocked_io); } -/* We allocate statically the bucket for the exception because we can't +/* We use a pre-allocated exception because we can't do a GC before the exception is raised (lack of stack descriptors - for the ccall to [caml_array_bound_error]. */ - -#define BOUND_MSG "index out of bounds" -#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) - -static struct { - header_t hdr; - value exn; - value arg; -} array_bound_error_bucket; - -static struct { - header_t hdr; - char data[BOUND_MSG_LEN + sizeof(value)]; -} array_bound_error_msg = { 0, BOUND_MSG }; + for the ccall to [caml_array_bound_error]). */ -static int array_bound_error_bucket_inited = 0; +static value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { - if (! array_bound_error_bucket_inited) { - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; - array_bound_error_bucket_inited = 1; - caml_page_table_add(In_static_data, - &array_bound_error_msg, - &array_bound_error_msg + 1); - array_bound_error_bucket_inited = 1; + if (caml_array_bound_error_exn == NULL) { + caml_array_bound_error_exn = + caml_named_value("Pervasives.array_bound_error"); + if (caml_array_bound_error_exn == NULL) { + fprintf(stderr, "Fatal error: exception " + "Invalid_argument(\"index out of bounds\")\n"); + exit(2); + } } - caml_raise((value) &array_bound_error_bucket.exn); + caml_raise(*caml_array_bound_error_exn); } int caml_is_special_exception(value exn) { diff --git a/asmrun/i386.S b/asmrun/i386.S index 306c9a58..347e967c 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -115,13 +115,10 @@ #define PROFILE_C #endif -#ifdef SYS_macosx +/* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it. */ #define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount) #define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount) -#else -#define ALIGN_STACK(amount) -#define UNDO_ALIGN_STACK(amount) -#endif /* Allocation */ @@ -304,11 +301,7 @@ LBL(106): LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer); CFI_ADJUST(-4) -#ifdef SYS_macosx addl $12, %esp ; CFI_ADJUST(-12) -#else - addl $4, %esp ; CFI_ADJUST(-4) -#endif LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack); CFI_ADJUST(-4) @@ -339,6 +332,8 @@ FUNCTION(caml_raise_exn) UNDO_ALIGN_STACK(8) ret LBL(110): + movl $0, G(caml_backtrace_pos) +LBL(111): movl %eax, %esi /* Save exception bucket in esi */ movl G(caml_exception_pointer), %edi /* SP of handler */ movl 0(%esp), %eax /* PC of raise */ @@ -356,19 +351,29 @@ LBL(110): ret CFI_ENDPROC +FUNCTION(caml_reraise_exn) + CFI_STARTPROC + testl $1, G(caml_backtrace_active) + jne LBL(111) + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer); CFI_ADJUST(-4) + UNDO_ALIGN_STACK(8) + ret + CFI_ENDPROC + /* Raise an exception from C */ FUNCTION(caml_raise_exception) CFI_STARTPROC PROFILE_C testl $1, G(caml_backtrace_active) - jne LBL(111) + jne LBL(112) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret -LBL(111): +LBL(112): movl 4(%esp), %esi /* Save exception bucket in esi */ ALIGN_STACK(12) pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */ @@ -449,10 +454,8 @@ FUNCTION(caml_ml_array_bound_error) movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) - /* For MacOS X: re-align the stack */ -#ifdef SYS_macosx + /* Re-align the stack */ andl $-16, %esp -#endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) CFI_ENDPROC diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index d7449741..61ec3416 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -27,6 +27,7 @@ EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_backtrace_pos: DWORD EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC @@ -205,6 +206,8 @@ _caml_raise_exn: pop _caml_exception_pointer ret L110: + mov _caml_backtrace_pos, 0 +L111: mov esi, eax ; Save exception bucket in esi mov edi, _caml_exception_pointer ; SP of handler mov eax, [esp] ; PC of raise @@ -219,18 +222,27 @@ L110: pop _caml_exception_pointer ret -; Raise an exception from C + PUBLIC _caml_reraise_exn + ALIGN 4 +_caml_reraise_exn: + test _caml_backtrace_active, 1 + jne L111 + mov esp, _caml_exception_pointer + pop _caml_exception_pointer + ret + + ; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 _caml_raise_exception: test _caml_backtrace_active, 1 - jne L111 + jne L112 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret -L111: +L112: mov esi, [esp+4] ; Save exception bucket in esi push _caml_exception_pointer ; arg 4: SP of handler push _caml_bottom_of_stack ; arg 3: SP of raise diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index edb389db..86c4f3e6 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -25,12 +25,11 @@ #include static void *getsym(void *handle, char *module, char *name){ - char *fullname = malloc(strlen(module) + strlen(name) + 5); + char *fullname = caml_strconcat(3, "caml", module, name); void *sym; - sprintf(fullname, "caml%s%s", module, name); sym = caml_dlsym (handle, fullname); /* printf("%s => %lx\n", fullname, (uintnat) sym); */ - free(fullname); + caml_stat_free(fullname); return sym; } diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index 94f4a29d..facbfbf0 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -200,31 +200,87 @@ caml_c_call: /* Reload allocation pointer and allocation limit*/ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ blr +/* Raise an exception from OCaml */ + .globl caml_raise_exn + .type caml_raise_exn, @function +caml_raise_exn: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L111 +.L110: + /* Pop trap frame */ + lwz 0, 0(29) + mr 1, 29 + mtctr 0 + lwz 29, 4(29) + addi 1, 1, 16 + /* Branch to handler */ + bctr +.L111: + li 0, 0 + Storeglobal(0, caml_backtrace_pos, 11) +.L112: + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + mflr 4 /* arg2: PC of raise */ + mr 5, 1 /* arg3: SP of raise */ + mr 6, 29 /* arg4: SP of handler */ + addi 1, 1, -16 /* reserve stack space for C call */ + bl caml_stash_backtrace + mr 3, 28 /* restore exn bucket */ + b .L110 /* raise the exn */ + + .globl caml_reraise_exn + .type caml_reraise_exn, @function +caml_reraise_exn: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne- .L112 + /* Pop trap frame */ + lwz 0, 0(29) + mr 1, 29 + mtctr 0 + lwz 29, 4(29) + addi 1, 1, 16 + /* Branch to handler */ + bctr + /* Raise an exception from C */ .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L121 +.L120: /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) /* Pop trap frame */ lwz 0, 0(1) lwz 29, 4(1) - mtlr 0 + mtctr 0 addi 1, 1, 16 /* Branch to handler */ - blr + bctr +.L121: + li 0, 0 + Storeglobal(0, caml_backtrace_pos, 11) + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */ + Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ + Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ + addi 1, 1, -16 /* reserve stack space for C call */ + bl caml_stash_backtrace + mr 3, 28 /* restore exn bucket */ + b .L120 /* raise the exn */ + /* Start the OCaml program */ diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index 309c955b..6fcb43cc 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -36,6 +36,14 @@ addis $2, 0, ha16($1) stg $0, lo16($1)($2) .endmacro +.macro Loadglobal32 /* reg,glob,tmp */ + addis $2, 0, ha16($1) + lwz $0, lo16($1)($2) +.endmacro +.macro Storeglobal32 /* reg,glob,tmp */ + addis $2, 0, ha16($1) + stw $0, lo16($1)($2) +.endmacro .text @@ -234,21 +242,22 @@ _caml_c_call: /* Raise an exception from OCaml */ .globl _caml_raise_exn _caml_raise_exn: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) + Loadglobal32 r11, _caml_backtrace_active, r11 cmpwi r11, 0 bne L110 L111: /* Pop trap frame */ lg r0, 0(r29) mr r1, r29 - mtlr r0 + mtctr r0 lg r29, WORD(r1) addi r1, r1, 16 /* Branch to handler */ - blr - + bctr L110: + li r0, 0 + Storeglobal32 r0, _caml_backtrace_pos, r11 +L114: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ mflr r4 /* arg 2: PC of raise */ @@ -259,12 +268,25 @@ L110: mr r3, r28 b L111 -/* Raise an exception from C */ + .globl _caml_reraise_exn +_caml_reraise_exn: + Loadglobal32 r11, _caml_backtrace_active, r11 + cmpwi r11, 0 + bne- L114 + /* Pop trap frame */ + lg r0, 0(r29) + mr r1, r29 + mtctr r0 + lg r29, WORD(r1) + addi r1, r1, 16 + /* Branch to handler */ + bctr + + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) + Loadglobal32 r11, _caml_backtrace_active, r11 cmpwi r11, 0 bne L112 L113: @@ -278,10 +300,10 @@ L113: /* Pop trap frame */ lg r0, 0(r1) lg r29, WORD(r1) - mtlr r0 + mtctr r0 addi r1, r1, 16 /* Branch to handler */ - blr + bctr L112: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 4f62bd38..df76c501 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -166,10 +166,8 @@ DECLARE_SIGNAL_HANDLER(trap_handler) #endif caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; -#if defined(SYS_rhapsody) caml_bottom_of_stack = (char *) CONTEXT_SP; caml_last_return_address = (uintnat) CONTEXT_PC; -#endif caml_array_bound_error(); } #endif diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index ff198475..23165ad6 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -92,6 +92,25 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) +/****************** ARM64, Linux */ + +#elif defined(TARGET_arm64) && defined(SYS_linux) + + #include + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->uc_mcontext.pc) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27]) + #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) + /****************** AMD64, Solaris x86 */ #elif defined(TARGET_amd64) && defined (SYS_solaris) @@ -234,6 +253,7 @@ #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29]) #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30]) #define CONTEXT_YOUNG_PTR (context->regs->gpr[31]) + #define CONTEXT_SP (context->regs->gpr[1]) /****************** PowerPC, BSD */ @@ -247,9 +267,11 @@ sigact.sa_flags = 0 typedef unsigned long context_reg; + #define CONTEXT_PC (context->sc_frame.srr0) #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29]) #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30]) #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31]) + #define CONTEXT_SP (context->sc_frame.fixreg[1]) /****************** SPARC, Solaris */ @@ -268,6 +290,7 @@ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC]) /* Local register number N is saved on the stack N words after the stack pointer */ + #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP]) #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n] #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5)) #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7)) diff --git a/asmrun/stack.h b/asmrun/stack.h index 57c87fa9..92b3c28a 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -25,7 +25,7 @@ #ifdef TARGET_i386 #define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#ifdef SYS_macosx +#ifndef SYS_win32 #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #else #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) @@ -56,6 +56,11 @@ #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #endif +#ifdef TARGET_arm64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + /* Structure of OCaml callback contexts */ struct caml_context { diff --git a/asmrun/startup.c b/asmrun/startup.c index 1ccd4eca..9a00f2d7 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -158,9 +158,7 @@ extern void caml_install_invalid_parameter_handler(); void caml_main(char **argv) { char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif value res; char tos; @@ -181,14 +179,10 @@ void caml_main(char **argv) caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; if (exe_name == NULL) exe_name = ""; -#ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; else exe_name = caml_search_exe_in_path(exe_name); -#else - exe_name = caml_search_exe_in_path(exe_name); -#endif caml_sys_init(exe_name, argv); if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) { if (caml_termination_hook != NULL) caml_termination_hook(NULL); diff --git a/boot/.ignore b/boot/.ignore index 8165156d..30c5866b 100644 --- a/boot/.ignore +++ b/boot/.ignore @@ -4,5 +4,3 @@ ocamlrun.exe ocamlyacc ocamlyacc.exe camlheader -myocamlbuild -myocamlbuild.native diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot deleted file mode 100755 index ab7ae092..00000000 Binary files a/boot/myocamlbuild.boot and /dev/null differ diff --git a/boot/ocamlc b/boot/ocamlc index 72164e97..f6b63f10 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index cdfd1dc7..d6901318 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 31beb410..02854fa1 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/.ignore b/build/.ignore deleted file mode 100644 index 274c6e55..00000000 --- a/build/.ignore +++ /dev/null @@ -1 +0,0 @@ -ocamlbuild_mixed_mode diff --git a/build/boot-c-parts.sh b/build/boot-c-parts.sh deleted file mode 100755 index fd5a35c7..00000000 --- a/build/boot-c-parts.sh +++ /dev/null @@ -1,50 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex - -. config/config.sh - -if "$WINDOWS"; then - MAKEOPTS='-f Makefile.nt' - LINK='cp -f' -else - MAKEOPTS='' - LINK='ln -s -f' -fi - -(cd byterun && make $MAKEOPTS) -(cd asmrun && make $MAKEOPTS all meta."$O" dynlink."$O") -(cd yacc && make $MAKEOPTS) - -if "$WINDOWS"; then - (cd win32caml && make) -fi - -mkdir -p _build/boot - -# Create a bunch of symlinks (or copies) to _build/boot -(cd _build/boot && -$LINK ../../byterun/ocamlrun$EXE \ - ../../byterun/libcamlrun.$A \ - ../../asmrun/libasmrun.$A \ - ../../yacc/ocamlyacc$EXE \ - ../../boot/ocamlc \ - ../../boot/ocamllex \ - ../../boot/ocamldep \ - . ) - -(cd boot && -[ -f boot/ocamlrun$EXE ] || $LINK ../byterun/ocamlrun$EXE . ) diff --git a/build/boot.sh b/build/boot.sh deleted file mode 100755 index c0d49a28..00000000 --- a/build/boot.sh +++ /dev/null @@ -1,39 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -TAG_LINE='true: -use_stdlib' - -# If you modify this list, modify it also in camlp4-native-only.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \ - -tag-line "$TAG_LINE" \ - boot/stdlib.cma boot/std_exit.cmo - -boot/ocamlrun boot/myocamlbuild.boot \ - -tag-line "$TAG_LINE" -log _boot_log1 \ - ocamlbuild/ocamlbuildlightlib.cma ocamlbuild/ocamlbuildlight.byte - -rm -f _build/myocamlbuild - -boot/ocamlrun boot/myocamlbuild.boot \ - -just-plugin -install-lib-dir _build/ocamlbuild -byte-plugin - -cp _build/myocamlbuild boot/myocamlbuild - -./boot/ocamlrun boot/myocamlbuild \ - -tag-line "$TAG_LINE" \ - $@ -log _boot_log2 boot/camlheader ocamlc diff --git a/build/buildbot b/build/buildbot deleted file mode 100755 index 5d3cffba..00000000 --- a/build/buildbot +++ /dev/null @@ -1,125 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# If you want to help me by participating to the build/test effort: -# http://gallium.inria.fr/~pouillar/ocaml-testing.html -# -- Nicolas Pouillard - -usage() { - echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | *)" - exit 1 -} - -logfile="buildbot.log" - -finish() { - curl -s -0 -F "log=@$logfile" \ - -F "host=`hostname`" \ - -F "mode=$mode-$opt_win-$opt_win2" \ - http://buildbot.feydakins.org/dropbox || : -} - -rm -f buildbot.failed -rm -f $logfile - -bad() { - touch buildbot.failed -} - -finish_if_bad() { - if [ -f buildbot.failed ]; then - finish - exit 2 - fi -} - -if figlet "test" > /dev/null 2> /dev/null; then - draw="figlet" -else - draw="echo ----------- " -fi - -if echo | tee -a tee.log > /dev/null 2> /dev/null; then - tee="tee -a $logfile" -else - tee=: -fi - -rm -f tee.log - -log() { - $draw $@ - $tee -} - -mode=$1 -shift 1 - -case "$mode" in - make|ocb|ocamlbuild) : ;; - *) usage;; -esac - -case "$1" in - win) - opt_win=win - opt_win2=$2 - shift 2 - Makefile=Makefile.nt;; - *) Makefile=Makefile;; -esac - -( [ -f config/Makefile ] && make -f $Makefile clean || : ) 2>&1 | log clean - -( ./build/distclean.sh || : ) 2>&1 | log distclean - -(cvs -q up -dP -r release311 || bad) 2>&1 | log cvs up -finish_if_bad - -case "$opt_win" in -win) - - # FIXME - sed -e 's/\(OTHERLIBRARIES=.*\) labltk/\1/' \ - < "config/Makefile.$opt_win2" > config/Makefile || bad - finish_if_bad - - cp config/m-nt.h config/m.h || bad - finish_if_bad - cp config/s-nt.h config/s.h || bad - finish_if_bad - ;; - -*) - (./configure --prefix `pwd`/_install $@ || bad) 2>&1 | log configure - finish_if_bad - ;; -esac - -case "$mode" in - make) - (make -f $Makefile world opt opt.opt install || bad) 2>&1 | log build install - finish_if_bad - ;; - ocb|ocamlbuild) - (./build/fastworld.sh || bad) 2>&1 | log build - finish_if_bad - (./build/install.sh || bad) 2>&1 | log install - finish_if_bad - ;; -esac - -(cat _build/not_installed || bad) 2>&1 | log not_installed - -finish diff --git a/build/camlp4-bootstrap-recipe.txt b/build/camlp4-bootstrap-recipe.txt deleted file mode 100644 index 3be13199..00000000 --- a/build/camlp4-bootstrap-recipe.txt +++ /dev/null @@ -1,181 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -=== Initial setup === - make clean - ./build/distclean.sh - ./configure -prefix `pwd`/_install - (cd otherlibs/labltk/browser; make help.ml) - ./build/fastworld.sh - # Go to "Bootstrap camlp4" - -=== Install the bootstrapping camlp4 processor === - ./build/install.sh - -=== Build camlp4 === - # This step is not needed right after a "./build/world.sh byte" - ./build/camlp4-byte-only.sh - -=== Bootstrap camlp4 === - # First "Build camlp4" - # Then "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-bootstrap.sh - # If the fixpoint not is reached yet - # Go to "Bootstrap camlp4" - # Otherwise - # Have a look at the changes in - # camlp4/boot it may be a good idea to commit them - -=== Generate Camlp4Ast.ml === - # First "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-mkCamlp4Ast.sh - -=== Case study "let open M in e" === - - Open the revised parser - Camlp4Parsers/Camlp4OCamlRevisedParser.ml - - Look for similar constructs, indeed rules - that start by the same prefix should in - the same entry. It is simpler to stick - them close to each other. - - [ "let"; r = opt_rec; ... - | "let"; "module"; m = a_UIDENT; ... - - So we naturally add something like - - | "let"; "open"; ... - - Then have a look to the "open" construct: - - | "open"; i = module_longident -> - - So we need a module_longident, it becomes: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - - Then we leave a dummy action but very close to what we want - in the end: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - <:expr< open_in $id:i$ $e$ >> - - Here it is just calling a (non-existing) function called open_in. - - Check that there is no other place where we have to duplicate this - rule (yuk!). In our case it is! The sequence entry have the "let" - rules again. - - Then go into Camlp4Parsers/Camlp4OCamlParser.ml and look for other - occurences. - - When copy/pasting the rule take care of SELF occurences, you may - have to replace it by expr and expr LEVEL ";" in our case. - - The return type of the production might be different from expr in - our case an action become <:str_item<...>> instead of <:expr<...> - - Watch the DELETE_RULE as well, in our case I'm searching for the - literal string "let" in the source: - - DELETE_RULE Gram expr: "let"; "open"; module_longident; "in"; SELF END; - - Then build and bootstrap. - - Then you can at last extend the AST, go in: - - Camlp4/Camlp4Ast.partial.ml - - And add the "open in" constructor (at the end). - - (* let open i in e *) - | ExOpI of loc and ident and expr - - Then "Generate Camlp4Ast.ml" and build. - - We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but - don't fix it now. Notice that you may need to disable '-warn-error' - in order to be able to successfully compile, despite of the warning. - - Then I hacked the camlp4/boot/camlp4boot.ml to generate: - Ast.ExOpI(_loc, i, e) - instead of - Ast.ExApp(_loc .... "open_in" ... i ... e ...) - - Build. Bootstrap once and build again. - - Then change the parsers again and replace the - open_in $id:i$ $e$ - by - let open $i$ in $e$ - - Then change the Parsetree generation in - Camlp4/Struct/Camlp4Ast2OCamlAst.ml - - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open (long_uident i) (expr e)) - - Change the pretty-printers as well (drawing inspiration in - "let module" in this case): - - In Camlp4/Printers/OCaml.ml: - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - And at the end of #simple_expr: - <:expr< let open $_$ in $_$ >> - - Have a look in Camlp4/Printers/OCamlr.ml as well. - -=== Second case study "with t := ..." === - -1/ Change the revised parser first. -Add new parsing rules for := but keep the old actions for now. - -2/ Change Camlp4Ast.partial.ml, add: - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - -3/ "Generate Camlp4Ast.ml" and build. - -4/ Change the generated camlp4/boot/camlp4boot.ml: - Look for ":=" and change occurences of - WcMod by WcMoS and WcTyp by WcTyS - -5/ Build (DO NOT bootstrap) - "Install the bootstrapping camlp4 processor" - -6/ Change the required files: - Camlp4/Printers/OCaml.ml: - just copy/paste&adapt what is done for - "... with type t = u" and - "... with module M = N" - Camlp4/Struct/Camlp4Ast2OCamlAst.ml: - I've factored out a common part under - another function and then copy/pasted. - Camlp4Parsers/Camlp4OCamlRevisedParser.ml: - Change the <:with_constr< type $...$ = $...$ >> - we've introduced earlier by replacing the '=' - by ':='. - Camlp4Parsers/Camlp4OCamlParser.ml: - Copy paste what we have done in Camlp4OCamlRevisedParser - and but we need to call opt_private_ctyp instead of - ctyp (just like the "type =" construct). - -7/ Build & Bootstrap diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh deleted file mode 100755 index 612e060e..00000000 --- a/build/camlp4-bootstrap.sh +++ /dev/null @@ -1,51 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -TMPTARGETS="\ - camlp4/boot/Lexer.ml" - -TARGETS="\ - camlp4/Camlp4/Struct/Camlp4Ast.ml \ - camlp4/boot/Camlp4.ml \ - camlp4/boot/camlp4boot.ml" - -for target in $TARGETS camlp4/boot/Camlp4Ast.ml; do - [ -f "$target" ] && mv "$target" "$target.old" - rm -f "_build/$target" -done - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $TMPTARGETS $TARGETS - -for t in $TARGETS; do - echo promote $t - cp _build/$t camlp4/boot/`basename $t` - if cmp _build/$t camlp4/boot/`basename $t`.old; then - echo fixpoint for $t - else - echo $t is different, you should rebootstrap it by cleaning, building and call this script - fi -done diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh deleted file mode 100755 index cbfe05c7..00000000 --- a/build/camlp4-byte-only.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh deleted file mode 100755 index 0ff20e8b..00000000 --- a/build/camlp4-mkCamlp4Ast.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -CAMLP4AST=camlp4/Camlp4/Struct/Camlp4Ast.ml -BOOTP4AST=camlp4/boot/Camlp4Ast.ml - -[ -f "$BOOTP4AST" ] && mv "$BOOTP4AST" "$BOOTP4AST.old" -rm -f "_build/$BOOTP4AST" -rm -f "_build/$CAMLP4AST" - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $CAMLP4AST - -echo promote $CAMLP4AST -cp _build/$CAMLP4AST camlp4/boot/`basename $CAMLP4AST` diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh deleted file mode 100755 index d53395c2..00000000 --- a/build/camlp4-native-only.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x - -# If you modify this list, modify it also in boot.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -$OCAMLBUILD -ignore "$STDLIB_MODULES" $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh deleted file mode 100644 index 8fbaafb5..00000000 --- a/build/camlp4-targets.sh +++ /dev/null @@ -1,46 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -CAMLP4_COMMON="\ - camlp4/Camlp4/Camlp4Ast.partial.ml \ - camlp4/boot/camlp4boot.byte" -CAMLP4_BYTE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmo \ - camlp4/Camlp4Top.cmo \ - camlp4/camlp4prof.byte$EXE \ - camlp4/mkcamlp4.byte$EXE \ - camlp4/camlp4.byte$EXE \ - camlp4/camlp4fulllib.cma" -CAMLP4_NATIVE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmx \ - camlp4/Camlp4Top.cmx \ - camlp4/camlp4prof.native$EXE \ - camlp4/mkcamlp4.native$EXE \ - camlp4/camlp4.native$EXE \ - camlp4/camlp4fulllib.cmxa" - -for i in camlp4boot camlp4r camlp4rf camlp4o camlp4of camlp4oof camlp4orf; do - CAMLP4_BYTE="$CAMLP4_BYTE camlp4/$i.byte$EXE camlp4/$i.cma" - CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/$i.native$EXE" -done - -cd camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters; do - for file in $dir/*.ml; do - base=camlp4/$dir/`basename $file .ml` - CAMLP4_BYTE="$CAMLP4_BYTE $base.cmo" - CAMLP4_NATIVE="$CAMLP4_NATIVE $base.cmx $base.$O" - done -done -cd .. diff --git a/build/distclean.sh b/build/distclean.sh deleted file mode 100755 index aa8b2f31..00000000 --- a/build/distclean.sh +++ /dev/null @@ -1,43 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -(cd byterun && make clean) || : -(cd asmrun && make clean) || : -(cd yacc && make clean) || : -rm -f build/ocamlbuild_mixed_mode -rm -rf _build -rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ - boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ - myocamlbuild_config.ml config/config.sh config/Makefile \ - boot/ocamlyacc tools/cvt_emit.bak tools/*.bak \ - config/s.h config/m.h boot/*.cm* _log _*_log* - -# from partial boot -rm -f driver/main.byte driver/optmain.byte lex/main.byte \ - tools/ocamlmklib.byte camlp4/build/location.ml \ - camlp4/build/location.mli \ - tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ - camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml - -# from ocamlbuild bootstrap -rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ - ocamlbuild/boot/ocamlbuild ocamlbuild/myocamlbuild_config.ml \ - ocamlbuild/myocamlbuild_config.mli -rm -rf ocamlbuild/_build ocamlbuild/_start - -# from the old build system -rm -f camlp4/build/camlp4_config.ml camlp4/**/*.cm* diff --git a/build/fastworld.sh b/build/fastworld.sh deleted file mode 100755 index 0e3302ef..00000000 --- a/build/fastworld.sh +++ /dev/null @@ -1,48 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh $@ - -cd .. -. build/targets.sh -OCAMLMKLIB_BYTE="tools/ocamlmklib.byte" -set -x -$OCAMLBUILD $@ -log _boot_fast_log \ - $STDLIB_BYTE $OCAMLOPT_BYTE $STDLIB_NATIVE \ - $OCAMLOPT_NATIVE $OCAMLMKLIB_BYTE $OTHERLIBS_UNIX_NATIVE $OCAMLBUILD_NATIVE - -rm -f _build/myocamlbuild -boot/ocamlrun boot/myocamlbuild \ - -just-plugin -install-lib-dir _build/ocamlbuild \ - -ocamlopt "../_build/ocamlopt.opt -nostdlib -I boot -I stdlib -I $UNIXDIR" -cp _build/myocamlbuild boot/myocamlbuild.native - -./boot/myocamlbuild.native $@ \ - $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \ - $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \ - $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE - -cd tools -make objinfo_helper -cd .. diff --git a/build/install.sh b/build/install.sh deleted file mode 100755 index d092d664..00000000 --- a/build/install.sh +++ /dev/null @@ -1,573 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/caml -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/vmthreads -mkdir -p $LIBDIR/threads -mkdir -p $LIBDIR/labltk -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $LIBDIR/ocamldoc -mkdir -p $LIBDIR/ocamldoc/custom -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -echo "Installing core libraries..." -installlibdir byterun/libcamlrun.$A asmrun/libasmrun.$A asmrun/libasmrunp.$A \ - $LIBDIR -installdir byterun/libcamlrun_shared$EXT_DLL $LIBDIR - -PUBLIC_INCLUDES="\ - alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h" - -cd byterun -for i in $PUBLIC_INCLUDES; do - echo " install caml/$i" - sed -f ../tools/cleanup-header $i > $LIBDIR/caml/$i -done -cd .. - -WIN32="" -if [ "x$EXE" = "x.exe" ]; then - installbin win32caml/ocamlwin.exe $PREFIX/OCamlWin.exe - WIN32=win32 -fi - -installdir otherlibs/"$WIN32"unix/unixsupport.h \ - otherlibs/bigarray/bigarray.h \ - $LIBDIR/caml - -installdir yacc/ocamlyacc$EXE byterun/ocamlrun$EXE $BINDIR - -installdir config/Makefile $LIBDIR/Makefile.config -installdir byterun/ld.conf $LIBDIR - -cd _build - -echo "Installing the toplevel and compilers..." -installbin ocaml$EXE $BINDIR/ocaml$EXE -installbin ocamlc$EXE $BINDIR/ocamlc$EXE -installbin ocamlopt$EXE $BINDIR/ocamlopt$EXE -installbin ocamlc.opt$EXE $BINDIR/ocamlc.opt$EXE -installbin ocamlopt.opt$EXE $BINDIR/ocamlopt.opt$EXE - -set=set # coloration workaround - -echo "Installing the standard library..." -installdir \ - stdlib/stdlib.cma \ - stdlib/stdlib.cmxa stdlib/stdlib.p.cmxa \ - stdlib/camlheader \ - stdlib/camlheader_ur \ - stdlib/std_exit.cm[io] stdlib/std_exit.ml \ - stdlib/arg.cmi stdlib/arg.ml stdlib/arg.mli \ - stdlib/array.cmi stdlib/array.ml stdlib/array.mli \ - stdlib/arrayLabels.cmi stdlib/arrayLabels.ml stdlib/arrayLabels.mli \ - stdlib/buffer.cmi stdlib/buffer.ml stdlib/buffer.mli \ - stdlib/callback.cmi stdlib/callback.ml stdlib/callback.mli \ - stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.ml stdlib/camlinternalLazy.mli \ - stdlib/camlinternalMod.cmi stdlib/camlinternalMod.ml stdlib/camlinternalMod.mli \ - stdlib/camlinternalOO.cmi stdlib/camlinternalOO.ml stdlib/camlinternalOO.mli \ - stdlib/char.cmi stdlib/char.ml stdlib/char.mli \ - stdlib/complex.cmi stdlib/complex.ml stdlib/complex.mli \ - stdlib/digest.cmi stdlib/digest.ml stdlib/digest.mli \ - stdlib/filename.cmi stdlib/filename.ml stdlib/filename.mli \ - stdlib/format.cmi stdlib/format.ml stdlib/format.mli \ - stdlib/gc.cmi stdlib/gc.ml stdlib/gc.mli \ - stdlib/genlex.cmi stdlib/genlex.ml stdlib/genlex.mli \ - stdlib/hashtbl.cmi stdlib/hashtbl.ml stdlib/hashtbl.mli \ - stdlib/int32.cmi stdlib/int32.ml stdlib/int32.mli \ - stdlib/int64.cmi stdlib/int64.ml stdlib/int64.mli \ - stdlib/lazy.cmi stdlib/lazy.ml stdlib/lazy.mli \ - stdlib/lexing.cmi stdlib/lexing.ml stdlib/lexing.mli \ - stdlib/list.cmi stdlib/list.ml stdlib/list.mli \ - stdlib/listLabels.cmi stdlib/listLabels.ml stdlib/listLabels.mli \ - stdlib/map.cmi stdlib/map.ml stdlib/map.mli \ - stdlib/marshal.cmi stdlib/marshal.ml stdlib/marshal.mli \ - stdlib/moreLabels.cmi stdlib/moreLabels.ml stdlib/moreLabels.mli \ - stdlib/nativeint.cmi stdlib/nativeint.ml stdlib/nativeint.mli \ - stdlib/obj.cmi stdlib/obj.ml stdlib/obj.mli \ - stdlib/oo.cmi stdlib/oo.ml stdlib/oo.mli \ - stdlib/parsing.cmi stdlib/parsing.ml stdlib/parsing.mli \ - stdlib/pervasives.cmi stdlib/pervasives.ml stdlib/pervasives.mli \ - stdlib/printexc.cmi stdlib/printexc.ml stdlib/printexc.mli \ - stdlib/printf.cmi stdlib/printf.ml stdlib/printf.mli \ - stdlib/queue.cmi stdlib/queue.ml stdlib/queue.mli \ - stdlib/random.cmi stdlib/random.ml stdlib/random.mli \ - stdlib/scanf.cmi stdlib/scanf.ml stdlib/scanf.mli \ - stdlib/sort.cmi stdlib/sort.ml stdlib/sort.mli \ - stdlib/stack.cmi stdlib/stack.ml stdlib/stack.mli \ - stdlib/stdLabels.cmi stdlib/stdLabels.ml stdlib/stdLabels.mli \ - stdlib/stream.cmi stdlib/stream.ml stdlib/stream.mli \ - stdlib/string.cmi stdlib/string.ml stdlib/string.mli \ - stdlib/stringLabels.cmi stdlib/stringLabels.ml stdlib/stringLabels.mli \ - stdlib/sys.cmi stdlib/sys.ml stdlib/sys.mli \ - stdlib/weak.cmi stdlib/weak.ml stdlib/weak.mli \ - stdlib/$set.cmi stdlib/$set.ml stdlib/$set.mli \ - stdlib/arg.cmx stdlib/arg.p.cmx \ - stdlib/array.cmx stdlib/array.p.cmx \ - stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx \ - stdlib/buffer.cmx stdlib/buffer.p.cmx \ - stdlib/callback.cmx stdlib/callback.p.cmx \ - stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx \ - stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx \ - stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx \ - stdlib/char.cmx stdlib/char.p.cmx \ - stdlib/complex.cmx stdlib/complex.p.cmx \ - stdlib/digest.cmx stdlib/digest.p.cmx \ - stdlib/filename.cmx stdlib/filename.p.cmx \ - stdlib/format.cmx stdlib/format.p.cmx \ - stdlib/gc.cmx stdlib/gc.p.cmx \ - stdlib/genlex.cmx stdlib/genlex.p.cmx \ - stdlib/hashtbl.cmx stdlib/hashtbl.p.cmx \ - stdlib/int32.cmx stdlib/int32.p.cmx \ - stdlib/int64.cmx stdlib/int64.p.cmx \ - stdlib/lazy.cmx stdlib/lazy.p.cmx \ - stdlib/lexing.cmx stdlib/lexing.p.cmx \ - stdlib/list.cmx stdlib/list.p.cmx \ - stdlib/listLabels.cmx stdlib/listLabels.p.cmx \ - stdlib/map.cmx stdlib/map.p.cmx \ - stdlib/marshal.cmx stdlib/marshal.p.cmx \ - stdlib/moreLabels.cmx stdlib/moreLabels.p.cmx \ - stdlib/nativeint.cmx stdlib/nativeint.p.cmx \ - stdlib/obj.cmx stdlib/obj.p.cmx \ - stdlib/oo.cmx stdlib/oo.p.cmx \ - stdlib/parsing.cmx stdlib/parsing.p.cmx \ - stdlib/pervasives.cmx stdlib/pervasives.p.cmx \ - stdlib/printexc.cmx stdlib/printexc.p.cmx \ - stdlib/printf.cmx stdlib/printf.p.cmx \ - stdlib/queue.cmx stdlib/queue.p.cmx \ - stdlib/random.cmx stdlib/random.p.cmx \ - stdlib/scanf.cmx stdlib/scanf.p.cmx \ - stdlib/sort.cmx stdlib/sort.p.cmx \ - stdlib/stack.cmx stdlib/stack.p.cmx \ - stdlib/stdLabels.cmx stdlib/stdLabels.p.cmx \ - stdlib/std_exit.cmx stdlib/std_exit.p.cmx stdlib/std_exit.$O stdlib/std_exit.p.$O \ - stdlib/stream.cmx stdlib/stream.p.cmx \ - stdlib/string.cmx stdlib/string.p.cmx \ - stdlib/stringLabels.cmx stdlib/stringLabels.p.cmx \ - stdlib/sys.cmx stdlib/sys.p.cmx \ - stdlib/weak.cmx stdlib/weak.p.cmx \ - stdlib/$set.cmx stdlib/$set.p.cmx \ - $LIBDIR - -installlibdir \ - stdlib/stdlib.$A stdlib/stdlib.p.$A \ - $LIBDIR - -echo "Installing ocamllex, ocamldebug..." -installbin lex/ocamllex$EXE $BINDIR/ocamllex$EXE -installbin debugger/ocamldebug$EXE $BINDIR/ocamldebug$EXE -installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE -installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE - -echo "Installing some tools..." -installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE -installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE -installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE -installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE -installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE -installbin tools/ocamlmktop.byte$EXE $BINDIR/ocamlmktop$EXE -installbin tools/ocamlprof.byte$EXE $BINDIR/ocamlprof$EXE -installbin toplevel/expunge.byte$EXE $LIBDIR/expunge$EXE -installbin tools/addlabels.byte $LIBDIR/addlabels -installbin tools/scrapelabels.byte $LIBDIR/scrapelabels -installbin otherlibs/dynlink/extract_crc.byte $LIBDIR/extract_crc -installbin otherlibs/labltk/lib/labltk$EXE $BINDIR/labltk$EXE -installbin otherlibs/labltk/browser/ocamlbrowser$EXE $BINDIR/ocamlbrowser$EXE -installbin otherlibs/labltk/compiler/pp$EXE $LIBDIR/labltk/pp$EXE -installbin otherlibs/labltk/lib/labltktop$EXE $LIBDIR/labltk/labltktop$EXE - -echo "Installing libraries..." -installdir \ - otherlibs/bigarray/bigarray.cma \ - otherlibs/dbm/dbm.cma \ - otherlibs/dynlink/dynlink.cma \ - otherlibs/"$WIN32"graph/graphics.cma \ - otherlibs/num/nums.cma \ - otherlibs/str/str.cma \ - otherlibs/"$WIN32"unix/unix.cma \ - otherlibs/bigarray/bigarray.cmxa \ - otherlibs/dbm/dbm.cmxa \ - otherlibs/dynlink/dynlink.cmxa \ - otherlibs/"$WIN32"graph/graphics.cmxa \ - otherlibs/num/nums.cmxa \ - otherlibs/str/str.cmxa \ - otherlibs/"$WIN32"unix/unix.cmxa \ - toplevel/toplevellib.cma \ - otherlibs/systhreads/thread.mli \ - otherlibs/systhreads/mutex.mli \ - otherlibs/systhreads/condition.mli \ - otherlibs/systhreads/event.mli \ - otherlibs/systhreads/threadUnix.mli \ - $LIBDIR - -installdir \ - otherlibs/labltk/support/fileevent.mli \ - otherlibs/labltk/support/fileevent.cmi \ - otherlibs/labltk/support/fileevent.cmx \ - otherlibs/labltk/support/protocol.mli \ - otherlibs/labltk/support/protocol.cmi \ - otherlibs/labltk/support/protocol.cmx \ - otherlibs/labltk/support/textvariable.mli \ - otherlibs/labltk/support/textvariable.cmi \ - otherlibs/labltk/support/textvariable.cmx \ - otherlibs/labltk/support/timer.mli \ - otherlibs/labltk/support/timer.cmi \ - otherlibs/labltk/support/timer.cmx \ - otherlibs/labltk/support/rawwidget.mli \ - otherlibs/labltk/support/rawwidget.cmi \ - otherlibs/labltk/support/rawwidget.cmx \ - otherlibs/labltk/support/widget.mli \ - otherlibs/labltk/support/widget.cmi \ - otherlibs/labltk/support/widget.cmx \ - otherlibs/labltk/support/tkthread.mli \ - otherlibs/labltk/support/tkthread.cmi \ - otherlibs/labltk/support/tkthread.cmo \ - otherlibs/labltk/support/tkthread.$O \ - otherlibs/labltk/support/tkthread.cmx \ - otherlibs/labltk/labltk/[^_]*.mli \ - otherlibs/labltk/labltk/*.cmi \ - otherlibs/labltk/labltk/*.cmx \ - otherlibs/labltk/camltk/[^_]*.mli \ - otherlibs/labltk/camltk/*.cmi \ - otherlibs/labltk/camltk/*.cmx \ - otherlibs/labltk/frx/frxlib.cma \ - otherlibs/labltk/frx/frxlib.cmxa \ - ../otherlibs/labltk/frx/*.mli \ - otherlibs/labltk/frx/*.cmi \ - otherlibs/labltk/jpf/jpflib.cma \ - otherlibs/labltk/jpf/jpflib.cmxa \ - otherlibs/labltk/jpf/*.mli \ - otherlibs/labltk/jpf/*.cmi \ - otherlibs/labltk/jpf/*.cmx \ - otherlibs/labltk/lib/labltk.cma \ - otherlibs/labltk/lib/labltk.cmxa \ - otherlibs/labltk/lib/labltk.cmx \ - otherlibs/labltk/compiler/tkcompiler \ - $LIBDIR/labltk - -installdir \ - otherlibs/systhreads/threads.cma \ - otherlibs/systhreads/threads.cmxa \ - otherlibs/systhreads/thread.cmi \ - otherlibs/systhreads/thread.cmx \ - otherlibs/systhreads/mutex.cmi \ - otherlibs/systhreads/mutex.cmx \ - otherlibs/systhreads/condition.cmi \ - otherlibs/systhreads/condition.cmx \ - otherlibs/systhreads/event.cmi \ - otherlibs/systhreads/event.cmx \ - otherlibs/systhreads/threadUnix.cmi \ - otherlibs/systhreads/threadUnix.cmx \ - $LIBDIR/threads - -installdir \ - otherlibs/bigarray/dllbigarray$EXT_DLL \ - otherlibs/dbm/dllmldbm$EXT_DLL \ - otherlibs/"$WIN32"graph/dllgraphics$EXT_DLL \ - otherlibs/num/dllnums$EXT_DLL \ - otherlibs/str/dllstr$EXT_DLL \ - otherlibs/systhreads/dllthreads$EXT_DLL \ - otherlibs/"$WIN32"unix/dllunix$EXT_DLL \ - otherlibs/threads/dllvmthreads$EXT_DLL \ - otherlibs/labltk/support/dlllabltk$EXT_DLL \ - $STUBLIBDIR - -installlibdir \ - otherlibs/threads/libvmthreads.$A \ - $LIBDIR/vmthreads - -installdir \ - otherlibs/threads/thread.cmi \ - otherlibs/threads/thread.mli \ - otherlibs/threads/mutex.cmi \ - otherlibs/threads/mutex.mli \ - otherlibs/threads/condition.cmi \ - otherlibs/threads/condition.mli \ - otherlibs/threads/event.cmi \ - otherlibs/threads/event.mli \ - otherlibs/threads/threadUnix.cmi \ - otherlibs/threads/threadUnix.mli \ - otherlibs/threads/threads.cma \ - otherlibs/threads/stdlib.cma \ - otherlibs/threads/unix.cma \ - $LIBDIR/vmthreads - -installlibdir \ - otherlibs/labltk/support/liblabltk.$A \ - otherlibs/labltk/lib/labltk.$A \ - otherlibs/labltk/jpf/jpflib.$A \ - otherlibs/labltk/frx/frxlib.$A \ - $LIBDIR/labltk - -installlibdir \ - otherlibs/bigarray/libbigarray.$A \ - otherlibs/dbm/libmldbm.$A \ - otherlibs/"$WIN32"graph/libgraphics.$A \ - otherlibs/num/libnums.$A \ - otherlibs/str/libstr.$A \ - otherlibs/systhreads/libthreads.$A \ - otherlibs/systhreads/libthreadsnat.$A \ - otherlibs/"$WIN32"unix/libunix.$A \ - $LIBDIR - -echo "Installing object files and interfaces..." -installdir \ - tools/profiling.cm[oi] \ - toplevel/topstart.cmo \ - toplevel/toploop.cmi \ - toplevel/topdirs.cmi \ - toplevel/topmain.cmi \ - typing/outcometree.cmi \ - typing/outcometree.mli \ - otherlibs/graph/graphicsX11.cmi \ - otherlibs/graph/graphicsX11.mli \ - otherlibs/dynlink/dynlink.cmi \ - otherlibs/dynlink/dynlink.mli \ - otherlibs/num/arith_status.cmi \ - otherlibs/num/arith_status.mli \ - otherlibs/num/big_int.cmi \ - otherlibs/num/big_int.mli \ - otherlibs/num/nat.cmi \ - otherlibs/num/nat.mli \ - otherlibs/num/num.cmi \ - otherlibs/num/num.mli \ - otherlibs/num/ratio.cmi \ - otherlibs/num/ratio.mli \ - otherlibs/bigarray/bigarray.cmi \ - otherlibs/bigarray/bigarray.mli \ - otherlibs/dbm/dbm.cmi \ - otherlibs/dbm/dbm.mli \ - otherlibs/dynlink/dynlink.cmx \ - otherlibs/"$WIN32"graph/graphics.cmi \ - otherlibs/"$WIN32"graph/graphics.mli \ - otherlibs/str/str.cmi \ - otherlibs/str/str.mli \ - otherlibs/"$WIN32"unix/unix.cmi \ - otherlibs/"$WIN32"unix/unix.mli \ - otherlibs/"$WIN32"unix/unixLabels.cmi \ - otherlibs/"$WIN32"unix/unixLabels.mli \ - otherlibs/num/arith_flags.cmx \ - otherlibs/num/int_misc.cmx \ - otherlibs/num/arith_status.cmx \ - otherlibs/num/big_int.cmx \ - otherlibs/num/nat.cmx \ - otherlibs/num/num.cmx \ - otherlibs/num/ratio.cmx \ - otherlibs/bigarray/bigarray.cmx \ - otherlibs/dbm/dbm.cmx \ - otherlibs/"$WIN32"graph/graphics.cmx \ - otherlibs/graph/graphicsX11.cmx \ - otherlibs/str/str.cmx \ - otherlibs/"$WIN32"unix/unix.cmx \ - otherlibs/"$WIN32"unix/unixLabels.cmx \ - $LIBDIR - -installlibdir \ - otherlibs/bigarray/bigarray.$A \ - otherlibs/dbm/dbm.$A \ - otherlibs/dynlink/dynlink.$A \ - otherlibs/"$WIN32"graph/graphics.$A \ - otherlibs/num/nums.$A \ - otherlibs/str/str.$A \ - otherlibs/"$WIN32"unix/unix.$A \ - stdlib/stdlib.$A \ - $LIBDIR - -installlibdir \ - otherlibs/systhreads/threads.$A \ - $LIBDIR/threads - -echo "Installing manuals..." -(cd ../man && make install) - -echo "Installing ocamldoc..." -installbin ocamldoc/ocamldoc $BINDIR/ocamldoc$EXE -installbin ocamldoc/ocamldoc.opt $BINDIR/ocamldoc.opt$EXE - -installdir \ - ../ocamldoc/ocamldoc.hva \ - ocamldoc/*.cmi \ - ocamldoc/odoc_info.mli ocamldoc/odoc_info.cm[ia] ocamldoc/odoc_info.cmxa \ - ocamldoc/odoc_info.$A \ - $LIBDIR/ocamldoc - -installdir \ - ocamldoc/stdlib_man/* \ - $MANDIR/man3 - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -cd camlp4 -CAMLP4DIR=$LIBDIR/camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir -done -installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR -installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR -cd .. - -echo "Installing ocamlbuild..." - -cd ocamlbuild -installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE - -installlibdir \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - ocamlbuild_pack.cmi \ - ocamlbuild_unix_plugin.cmi \ - ocamlbuild_unix_plugin.cmo \ - ocamlbuild_unix_plugin.cmx \ - ocamlbuild_unix_plugin.$O \ - ocamlbuild_executor.cmi \ - ocamlbuild_executor.cmo \ - ocamlbuild_executor.cmx \ - ocamlbuild_executor.$O \ - ocamlbuild.cmo \ - ocamlbuild.cmx \ - ocamlbuild.$O \ - $LIBDIR/ocamlbuild -cd .. - -installdir \ - ../ocamlbuild/man/ocamlbuild.1 \ - $MANDIR/man1 diff --git a/build/mixed-boot.sh b/build/mixed-boot.sh deleted file mode 100755 index 133f8cff..00000000 --- a/build/mixed-boot.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -ex -cd `dirname $0`/.. -touch build/ocamlbuild_mixed_mode -mkdir -p _build -cp -rf boot _build/ -./build/mkconfig.sh -./build/mkmyocamlbuild_config.sh -./build/boot.sh diff --git a/build/mkconfig.sh b/build/mkconfig.sh deleted file mode 100755 index 8cf1773d..00000000 --- a/build/mkconfig.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ - -e 's/\$(\([^)]*\))/${\1}/g' \ - -e 's/^FLEX.*$//g' \ - -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ - config/Makefile > config/config.sh - -if [ "x$EXE" = "x.exe" -a "x$SYSTEM" != "xcygwin" ]; then - echo "WINDOWS=true" >> config/config.sh -else - echo "WINDOWS=false" >> config/config.sh -fi diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh deleted file mode 100755 index 75d6e9ca..00000000 --- a/build/mkmyocamlbuild_config.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed \ - -e 's/^.*FLEXDIR.*$//g' \ - -e '/^SET_LD_PATH/d' \ - -e 's/^#ml \(.*\)/\1/' \ - -e 's/^\([^"][^"]*\("[^"]*"[^"]*\)*\)#.*$/\1/' \ - -e 's/^\(#.*\)$/(* \1 *)/' \ - -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ - -e 's/^\([^(=]*\)=\([^"]*\)$/let <:lower<\1>> = "\2";;/' \ - -e 's/\$(AS)/as/g' \ - -e 's/\$(\([^)]*\))/"\^<:lower<\1>>\^"/g' \ - -e 's/""\^//g' \ - -e 's/\^""//g' \ - -e 's/^let <:lower myocamlbuild_config.ml diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh deleted file mode 100755 index a1bf141e..00000000 --- a/build/mkruntimedef.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -echo 'let builtin_exceptions = [|'; \ -sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ -sed -e '$s/;$//'; \ -echo '|]'; \ -echo 'let builtin_primitives = [|'; \ -sed -e 's/.*/ "&";/' -e '$s/;$//' byterun/primitives; \ -echo '|]' diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh deleted file mode 100755 index 34ad894f..00000000 --- a/build/myocamlbuild.sh +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -xe -if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then - if [ ! -x ocamlbuild/_build/ocamlbuildlight.byte ]; then - (cd ocamlbuild && ${GNUMAKE:-make}) - fi - mkdir -p _build/ocamlbuild - for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" - do - cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild - done -fi -rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli -rm -rf _build/myocamlbuild boot/myocamlbuild boot/myocamlbuild.native -./boot/ocamlrun _build/ocamlbuild/ocamlbuildlight.byte -no-hygiene \ - -tag debug -install-lib-dir _build/ocamlbuild -byte-plugin -just-plugin -cp _build/myocamlbuild boot/myocamlbuild.boot diff --git a/build/new-build-system b/build/new-build-system deleted file mode 100644 index acd7125d..00000000 --- a/build/new-build-system +++ /dev/null @@ -1,52 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -_tags # Defines tags to setup exceptions -myocamlbuild.ml # Contains all needed rules that are differents -boot/ocamldep -myocamlbuild_config.mli -utils/config.mlbuild # Should be renamed as utils/config.ml - -# Files that just contain module names of object files. -**/*.mllib # Files that describe the contents of an OCaml library -**/*.mlpack # Files that describe the contents of an OCaml package -**/*.cilb # Files that describe the contents of an C static library -**/*.dilb # Files that describe the contents of an C dynamic library - -build/ - world.sh # Build all the OCaml world - world.byte.sh # Build the bytecode world - world.native.sh # Build the native world - world.all.sh # Build all the world the don't bootstrap - fastworld.sh # Same as above but faster - boot-c-parts.sh # Compile byterun, ocamlyacc and asmrun with the Makefiles - boot.sh # Compile the stdlib and ocamlc - camlp4-targets.sh # Setup camlp4 targets - otherlibs-targets.sh # Setup otherlibs targets - targets.sh # All targets of the OCaml distribution - - - install.sh # Install all needed files - distclean.sh # Clean all generated files - - myocamlbuild.sh # Regenerate the boot/myocamlbuild program - mkconfig.sh # Generate config/config.sh - mkmyocamlbuild_config.sh # Generate myocamlbuild_config.ml - - camlp4-bootstrap.sh - - # Partial stuffs (just camlp4 and ocamlbuild) - mixed-boot.sh - camlp4-byte-only.sh - camlp4-native-only.sh - ocamlbuild-byte-only.sh - ocamlbuild-native-only.sh diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh deleted file mode 100755 index aeb5bcba..00000000 --- a/build/ocamlbuild-byte-only.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh deleted file mode 100755 index 4d7decfc..00000000 --- a/build/ocamlbuild-native-only.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh deleted file mode 100755 index 285c561a..00000000 --- a/build/ocamlbuildlib-native-only.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh deleted file mode 100644 index bd28a0dc..00000000 --- a/build/otherlibs-targets.sh +++ /dev/null @@ -1,120 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -OTHERLIBS_BYTE="" -OTHERLIBS_NATIVE="" -OTHERLIBS_UNIX_NATIVE="" -UNIXDIR="otherlibs/unix" - -add_native() { - for native_file in $@; do - OTHERLIBS_NATIVE="$OTHERLIBS_NATIVE otherlibs/$lib/$native_file" - case $lib in - unix|win32unix) - OTHERLIBS_UNIX_NATIVE="$OTHERLIBS_UNIX_NATIVE otherlibs/$lib/$native_file";; - esac - done -} - -add_byte() { - for byte_file in $@; do - OTHERLIBS_BYTE="$OTHERLIBS_BYTE otherlibs/$lib/$byte_file" - done -} - -add_file() { - add_byte $@ - add_native $@ -} - -add_bin() { - for bin_file in $@; do - add_byte $bin_file.byte$EXE - add_native $bin_file.native$EXE - done -} - -add_c_lib() { - add_file "lib$1.$A" -} - -add_ocaml_lib() { - add_native "$1.cmxa" - add_native "$1.$A" - add_byte "$1.cma" -} - -add_dll() { - add_file "dll$1$EXT_DLL" -} - -add() { - add_c_lib $1 - add_ocaml_lib $1 - add_dll $1 -} - -THREADS_CMIS="thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi" - -for lib in $OTHERLIBRARIES; do - case $lib in - num) - add nums;; - systhreads) - add_ocaml_lib threads - add_dll threads - add_file $THREADS_CMIS - add_byte libthreads.$A - add_native libthreadsnat.$A;; - graph|win32graph) - add graphics;; - threads) - add_byte pervasives.cmi pervasives.mli \ - $THREADS_CMIS marshal.cmi marshal.mli \ - stdlib.cma unix.cma threads.cma libvmthreads.$A;; - labltk) - add_file support/camltk.h - add_byte support/byte.otarget - add_native support/native.otarget - add_file support/liblabltk.$A - add_byte compiler/tkcompiler$EXE compiler/pp$EXE - add_file labltk/tk.ml labltk/labltk.ml - add_byte labltk/byte.otarget - add_native labltk/native.otarget - add_byte camltk/byte.otarget - add_native camltk/native.otarget - add_ocaml_lib lib/labltk - add_byte lib/labltktop$EXE lib/labltk$EXE - add_ocaml_lib jpf/jpflib - add_ocaml_lib frx/frxlib - add_byte browser/ocamlbrowser$EXE - ;; - dbm) - add_ocaml_lib dbm - add_c_lib mldbm;; - dynlink) - add_ocaml_lib dynlink - add_native dynlink.cmx dynlink.$O - add_file $lib.cmi extract_crc;; - win32unix) - UNIXDIR="otherlibs/win32unix" - add_file unixsupport.h cst2constr.h socketaddr.h - add unix;; - unix) - add_file unixsupport.h - add unix;; - *) - add $lib - esac -done diff --git a/build/partial-install.sh b/build/partial-install.sh deleted file mode 100755 index c06154a8..00000000 --- a/build/partial-install.sh +++ /dev/null @@ -1,188 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -###################################### -######### Copied from build/install.sh -###################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -cd _build - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -if test -d camlp4; then - cd camlp4 - CAMLP4DIR=$LIBDIR/camlp4 - for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir - done - installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR - installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR - cd .. -fi - -echo "Installing ocamlbuild..." -cd ocamlbuild -installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE - -installlibdir \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - ocamlbuild_pack.cmi \ - ocamlbuild_unix_plugin.cmi \ - ocamlbuild_unix_plugin.cmo \ - ocamlbuild_unix_plugin.cmx \ - ocamlbuild_unix_plugin.$O \ - ocamlbuild_executor.cmi \ - ocamlbuild_executor.cmo \ - ocamlbuild_executor.cmx \ - ocamlbuild_executor.$O \ - ocamlbuild.cmo \ - ocamlbuild.cmx \ - ocamlbuild.$O \ - $LIBDIR/ocamlbuild -cd .. - -installdir \ - ../ocamlbuild/man/ocamlbuild.1 \ - $MANDIR/man1 diff --git a/build/targets.sh b/build/targets.sh deleted file mode 100644 index 219f73cd..00000000 --- a/build/targets.sh +++ /dev/null @@ -1,62 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -. config/config.sh -. build/otherlibs-targets.sh -. build/camlp4-targets.sh - -INSTALL_BIN="$BINDIR" -export INSTALL_BIN - -STDLIB_BYTE="stdlib/libcamlrun.$A stdlib/stdlib.cma \ - stdlib/std_exit.cmo stdlib/camlheader stdlib/camlheader_ur" -OCAMLLEX_BYTE=lex/ocamllex$EXE -OCAMLC_BYTE=ocamlc$EXE -OCAMLOPT_BYTE=ocamlopt$EXE -OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \ - ocamlbuild/ocamlbuildlightlib.cma \ - ocamlbuild/ocamlbuild.byte$EXE \ - ocamlbuild/ocamlbuildlight.byte$EXE" -TOPLEVEL=ocaml$EXE -TOOLS_BYTE="tools/objinfo.byte$EXE \ - tools/ocamldep.byte$EXE tools/profiling.cmo \ - tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \ - tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \ - tools/scrapelabels.byte tools/addlabels.byte \ - tools/dumpobj.byte$EXE" -if [ ! -z "$DEBUGGER" ]; then - DEBUGGER=debugger/ocamldebug$EXE -fi -OCAMLDOC_BYTE="ocamldoc/ocamldoc$EXE ocamldoc/odoc_info.cma" -STDLIB_NATIVE="stdlib/stdlib.cmxa stdlib/std_exit.cmx asmrun/libasmrun.$A" -case $PROFILING in -prof) - STDLIB_NATIVE="$STDLIB_NATIVE asmrun/libasmrunp.$A \ - stdlib/stdlib.p.cmxa stdlib/std_exit.p.cmx";; -noprof) ;; -*) echo "unexpected PROFILING value $PROFILING"; exit 1;; -esac -OCAMLC_NATIVE=ocamlc.opt$EXE -OCAMLOPT_NATIVE=ocamlopt.opt$EXE -OCAMLLEX_NATIVE=lex/ocamllex.opt$EXE -TOOLS_NATIVE=tools/ocamldep.native$EXE -OCAMLDOC_NATIVE="ocamldoc/ocamldoc.opt$EXE ocamldoc/odoc_info.cmxa ocamldoc/stdlib_man/Pervasives.3o" -OCAMLBUILDLIB_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlightlib.cmxa" -OCAMLBUILD_NATIVE="$OCAMLBUILDLIB_NATIVE \ - ocamlbuild/ocamlbuild.native$EXE \ - ocamlbuild/ocamlbuildlight.native$EXE" -if [ -x boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi diff --git a/build/tolower.sed b/build/tolower.sed deleted file mode 100644 index ce0eb165..00000000 --- a/build/tolower.sed +++ /dev/null @@ -1,23 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# tolower.sed expands one ...<:lower>... to ...foo... per line -h -s/.*<:lower<\(.*\)>>.*/\1/ -t cont -b end -:cont -y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ -s/$/|/ -G -s/\(.*\)|\n\(.*\)<:lower<\(.*\)>>/\2\1/ -:end diff --git a/build/world.all.sh b/build/world.all.sh deleted file mode 100755 index 45c053cd..00000000 --- a/build/world.all.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL \ - $TOOLS_BYTE $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE \ - $CAMLP4_BYTE $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff --git a/build/world.byte.sh b/build/world.byte.sh deleted file mode 100755 index 5a520b99..00000000 --- a/build/world.byte.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL $TOOLS_BYTE \ - $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE $CAMLP4_BYTE diff --git a/build/world.native.sh b/build/world.native.sh deleted file mode 100755 index 4f99467b..00000000 --- a/build/world.native.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff --git a/build/world.sh b/build/world.sh deleted file mode 100755 index 3b08dc78..00000000 --- a/build/world.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -case "$1" in - all|a|al) mode=all;; - byte|b|by|byt) mode=byte;; - native|na|nat|nati|nativ) mode=native;; - *) echo 'Unexpected target. Expected targets are: all,byte,native' \ - >/dev/stderr - exit 1;; -esac -shift -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh "$@" -./world."$mode".sh "$@" diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index e933df53..af5f0a3f 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -74,7 +74,7 @@ let make_branch cont = match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) - | Kraise :: _ -> (Kraise, cont) + | Kraise k :: _ -> (Kraise k, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont @@ -108,7 +108,7 @@ let rec add_pop n cont = match cont with Kpop m :: cont -> add_pop (n + m) cont | Kreturn m :: cont -> Kreturn(n + m) :: cont - | Kraise :: _ -> cont + | Kraise _ :: _ -> cont | _ -> Kpop n :: cont (* Add the constant "unit" in front of a continuation *) @@ -233,9 +233,15 @@ let add_event ev = (**** Compilation of a lambda expression ****) -(* association staticraise numbers -> (lbl,size of stack *) +let try_blocks = ref [] (* list of stack size for each nested try block *) + +(* association staticraise numbers -> (lbl,size of stack, try_blocks *) let sz_static_raises = ref [] + +let push_static_raise i lbl_handler sz = + sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises + let find_raise_label i = try List.assoc i !sz_static_raises @@ -247,8 +253,8 @@ let find_raise_label i = (* Will the translation of l lead to a jump to label ? *) let code_as_jump l sz = match l with | Lstaticraise (i,[]) -> - let label,size = find_raise_label i in - if sz = size then + let label,size,tb = find_raise_label i in + if sz = size && tb == !try_blocks then Some label else None @@ -275,6 +281,10 @@ let compunit_name = ref "" let max_stack_used = ref 0 + +(* Sequence of string tests *) + + (* Translate a primitive to a bytecode instruction (possibly a call to a C function) *) @@ -397,10 +407,15 @@ let comp_primitive p args = | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args + | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -584,8 +599,8 @@ let rec comp_expr env exp sz cont = comp_expr env exp1 sz (Kstrictbranchif lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Praise, [arg]) -> - comp_expr env arg sz (Kraise :: discard_dead_code cont) + | Lprim(Praise k, [arg]) -> + comp_expr env arg sz (Kraise k :: discard_dead_code cont) | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) when is_immed n -> comp_expr env arg sz (Koffsetint n :: cont) @@ -618,7 +633,7 @@ let rec comp_expr env exp sz cont = comp_args env args sz (comp_primitive p args :: cont) | Lprim(p, args) -> comp_args env args sz (comp_primitive p args :: cont) - | Lstaticcatch (body, (i, vars) , handler) -> + | Lstaticcatch (body, (i, vars) , handler) -> let nvars = List.length vars in let branch1, cont1 = make_branch cont in let r = @@ -628,8 +643,7 @@ let rec comp_expr env exp sz cont = (comp_expr (add_vars vars (sz+1) env) handler (sz+nvars) (add_pop nvars cont1)) in - sz_static_raises := - (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_static_raise i lbl_handler (sz+nvars); push_dummies nvars (comp_expr env body (sz+nvars) (add_pop nvars (branch1 :: cont2))) @@ -640,30 +654,39 @@ let rec comp_expr env exp sz cont = (Kpush::comp_expr (add_var var (sz+1) env) handler (sz+1) (add_pop 1 cont1)) in - sz_static_raises := - (i, (lbl_handler, sz)) :: !sz_static_raises ; + push_static_raise i lbl_handler sz; comp_expr env body sz (branch1 :: cont2) end in sz_static_raises := List.tl !sz_static_raises ; r | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label,size = find_raise_label i in + let label,size,tb = find_raise_label i in + let cont = branch_to label cont in + let rec loop sz tbb = + if tb == tbb then add_pop (sz-size) cont + else match tbb with + | [] -> assert false + | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb) + in + let cont = loop sz !try_blocks in begin match args with | [arg] -> (* optim, argument passed in accumulator *) - comp_expr env arg sz - (add_pop (sz-size) (branch_to label cont)) - | _ -> - comp_exit_args env args sz size - (add_pop (sz-size) (branch_to label cont)) + comp_expr env arg sz cont + | _ -> comp_exit_args env args sz size cont end | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: - Klabel lbl_handler :: Kpush :: - comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + let body_cont = + Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1) + in + try_blocks := sz :: !try_blocks; + let l = comp_expr env body (sz+4) body_cont in + try_blocks := List.tl !try_blocks; + Kpushtrap lbl_handler :: l | Lifthenelse(cond, ifso, ifnot) -> comp_binary_test env cond ifso ifnot sz cont | Lsequence(exp1, exp2) -> @@ -691,10 +714,11 @@ let rec comp_expr env exp sz cont = | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let store = Storer.mk_store () in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -703,10 +727,20 @@ let rec comp_expr env exp sz cont = (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts; List.iter (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; - (* Compile and label actions *) let acts = store.act_get () in - let lbls = Array.create (Array.length acts) 0 in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -714,15 +748,17 @@ let rec comp_expr env exp sz cont = done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c) + | Lstringswitch (arg,sw,d) -> + comp_expr env (Matching.expand_stringswitch arg sw d) sz cont | Lassign(id, expr) -> begin try let pos = Ident.find_same id env.ce_stack in @@ -827,6 +863,10 @@ and comp_binary_test env cond ifso ifnot sz cont = comp_expr env cond sz cont_cond +(* Compile string switch *) + +and comp_string_switch env arg cases default sz cont = () + (**** Compilation of a code block (with tracking of stack usage) ****) let comp_block env exp sz cont = @@ -890,3 +930,10 @@ let compile_phrase expr = let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) + +let reset () = + label_counter := 0; + sz_static_raises := []; + compunit_name := ""; + Stack.clear functions_to_compile; + max_stack_used := 0 diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index 3c24cc8e..24f1d64f 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -17,3 +17,4 @@ open Instruct val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list +val reset: unit -> unit diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index fdcb0d88..7c96dfd0 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -60,7 +60,7 @@ let copy_object_file ppf oc name = raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -117,3 +117,15 @@ let report_error ppf = function | Not_an_object_file name -> fprintf ppf "The file %a is not a bytecode object file" Location.print_filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := [] diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli index 757874cb..b9a4ced8 100644 --- a/bytecomp/bytelibrarian.mli +++ b/bytecomp/bytelibrarian.mli @@ -30,3 +30,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 20983668..c0f8f6a9 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -113,7 +113,7 @@ let scan_file obj_name tolink = raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -158,15 +158,20 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let check_consistency ppf file_name cu = begin try List.iter - (fun (name, crc) -> - if name = cu.cu_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -183,7 +188,11 @@ let check_consistency ppf file_name cu = (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces + +let clear_crc_interfaces () = + Consistbl.clear crc_interfaces; + interfaces := [] (* Record compilation events *) @@ -256,7 +265,7 @@ let output_debug_info oc = List.iter (fun (ofs, evl) -> output_binary_int oc ofs; - Array.iter (output_string oc) evl) + Array.iter (output_bytes oc) evl) !debug_info; debug_info := [] @@ -307,19 +316,20 @@ let link_bytecode ppf tolink exec_name standalone = (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in - if standalone then begin + let check_dlls = standalone && Config.target = Config.host in + if check_dlls then begin (* Initialize the DLL machinery *) Dll.init_compile !Clflags.no_std_include; Dll.add_path !load_path; try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - let output_fun = output_string outchan + let output_fun = output_bytes outchan and currpos_fun () = pos_out outchan - start_code in List.iter (link_file ppf output_fun currpos_fun) tolink; - if standalone then Dll.close_all_dlls(); + if check_dlls then Dll.close_all_dlls(); (* The final STOP instruction *) output_byte outchan Opcodes.opSTOP; output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; @@ -370,12 +380,12 @@ let output_code_string_counter = ref 0 let output_code_string outchan code = let pos = ref 0 in - let len = String.length code in + let len = Bytes.length code in while !pos < len do - let c1 = Char.code(code.[!pos]) in - let c2 = Char.code(code.[!pos + 1]) in - let c3 = Char.code(code.[!pos + 2]) in - let c4 = Char.code(code.[!pos + 3]) in + let c1 = Char.code(Bytes.get code !pos) in + let c2 = Char.code(Bytes.get code (!pos + 1)) in + let c3 = Char.code(Bytes.get code (!pos + 2)) in + let c4 = Char.code(Bytes.get code (!pos + 3)) in pos := !pos + 4; Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; incr output_code_string_counter; @@ -439,11 +449,11 @@ let link_bytecode_as_c ppf tolink outfile = \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let currpos = ref 0 in let output_fun code = output_code_string outchan code; - currpos := !currpos + String.length code + currpos := !currpos + Bytes.length code and currpos_fun () = !currpos in List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) @@ -621,3 +631,20 @@ let report_error ppf = function | Not_compatible_32 -> fprintf ppf "Generated bytecode executable cannot be run\ \ on a 32-bit platform" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := []; + missing_globals := IdentSet.empty; + Consistbl.clear crc_interfaces; + implementations_defined := []; + debug_info := []; + output_code_string_counter := 0 diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 6e123c3f..37dad2b5 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -13,11 +13,12 @@ (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit +val reset : unit -> unit val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list type error = File_not_found of string diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index f548c771..3348f46d 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -17,6 +17,8 @@ open Misc open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +32,7 @@ exception Error of error let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -98,7 +101,9 @@ let read_member_info file = ( if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = input_bytes ic (String.length Config.cmo_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -137,6 +142,10 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -182,6 +191,8 @@ let build_global_target oc target_name members mapping pos coercion = let lam = Translmod.transl_package components (Ident.create_persistent target_name) coercion in + if !Clflags.dump_lambda then + Format.printf "%a@." Printlambda.lambda lam; let instrs = Bytegen.compile_implementation target_name lam in let rel = @@ -213,6 +224,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); let pos_final = pos_out oc in let imports = List.filter @@ -223,7 +235,8 @@ let package_object_files ppf files targetfile targetname coercion = cu_pos = pos_code; cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; - cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_imports = + (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; @@ -238,7 +251,7 @@ let package_object_files ppf files targetfile targetname coercion = (* The entry point *) -let package_files ppf files targetfile = +let package_files ppf initial_env files targetfile = let files = List.map (fun f -> @@ -249,11 +262,12 @@ let package_files ppf files targetfile = let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try - let coercion = Typemod.package_units files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret - with x -> - remove_file targetfile; raise x + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + let ret = package_object_files ppf files targetfile targetname coercion in + ret + with x -> + remove_file targetfile; raise x (* Error report *) @@ -276,3 +290,16 @@ let report_error ppf = function Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + relocs := []; + events := []; + primitives := []; + force_link := false diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 04de0726..69e3c77a 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -13,7 +13,7 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t @@ -25,3 +25,4 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit +val reset: unit -> unit diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 5af3bc52..759bde3b 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -46,12 +46,14 @@ let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in + let header = + really_input_string ic (String.length Config.exec_magic_number) + in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for _i = 1 to num_sections do - let name = Misc.input_bytes ic 4 in + let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -77,7 +79,7 @@ let seek_section ic name = (* Return the contents of a section, as a string *) let read_section_string ic name = - Misc.input_bytes ic (seek_section ic name) + really_input_string ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) @@ -90,3 +92,7 @@ let read_section_struct ic name = let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + +let reset () = + section_table := []; + section_beginning := 0 diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index b9639c1f..12e679d7 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -50,3 +50,5 @@ val read_section_struct: in_channel -> string -> 'a val pos_first_section: in_channel -> int (* Return the position of the beginning of the first section *) + +val reset: unit -> unit diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index abf4f1af..0c0f08f0 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -27,7 +27,8 @@ type compilation_unit = mutable cu_pos: int; (* Absolute position in file *) cu_codesize: int; (* Size of code block *) cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_imports: + (string * Digest.t option) list; (* Names and CRC of intfs imported *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 5c62b9ed..21688e08 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -173,3 +173,9 @@ let init_toplevel dllpath = opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true + +let reset () = + search_path := []; + opened_dlls :=[]; + names_of_opened_dlls := []; + linking_in_core := false diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 975315e2..878ffb91 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -59,3 +59,5 @@ val init_compile: bool -> unit contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit + +val reset: unit -> unit diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 2f1d5859..77df4611 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -20,6 +20,8 @@ open Instruct open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -80,7 +82,7 @@ let label_table = ref ([| |] : label_definition array) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -135,8 +137,12 @@ and slot_for_c_prim name = (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -144,8 +150,9 @@ let record_event ev = let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -243,7 +250,9 @@ let emit_instr = function | Kboolnot -> out opBOOLNOT | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl | Kpoptrap -> out opPOPTRAP - | Kraise -> out opRAISE + | Kraise Raise_regular -> out opRAISE + | Kraise Raise_reraise -> out opRERAISE + | Kraise Raise_notrace -> out opRAISE_NOTRACE | Kcheck_signals -> out opCHECK_SIGNALS | Kccall(name, n) -> if n <= 5 @@ -351,7 +360,7 @@ let rec emit = function (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -361,8 +370,12 @@ let to_file outchan unit_name code = LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in @@ -371,7 +384,7 @@ let to_file outchan unit_name code = cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imported_units(); + cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; @@ -392,7 +405,7 @@ let to_memory init_code fun_code = emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in init(); @@ -407,3 +420,9 @@ let to_packed_file outchan code = let reloc = !reloc_info in init(); reloc + +let reset () = + out_buffer := LongString.create 1024; + out_position := 0; + label_table := [| |]; + reloc_info := [] diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 60d79143..e2fdb815 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -15,13 +15,14 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> - string * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list (* Arguments: initialization code (terminated by STOP) function code @@ -36,3 +37,5 @@ val to_packed_file: list of instructions to emit Result: relocation information (reversed) *) + +val reset: unit -> unit diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 5edcacd2..70d62229 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -85,7 +85,7 @@ type instruction = | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index d81228ac..024dba13 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -105,7 +105,7 @@ type instruction = | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index cfced858..4ad8e9b4 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -41,7 +49,7 @@ type primitive = (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -137,6 +147,11 @@ and bigarray_layout = | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -161,6 +176,7 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -195,68 +211,96 @@ let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) - -let name_lambda arg fn = +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)|Const_float_array _) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply (e,es,loc) -> + Lapply (tr_rec env e,tr_recs env es,Location.none) + | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet (str,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es) -> + Lprim (p,tr_recs env es) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) + +let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function @@ -268,6 +312,11 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () @@ -286,10 +335,11 @@ let iter f = function f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + iter_opt f sw.sw_failaction + | Lstringswitch (arg,cases,default) -> + f arg ; + List.iter (fun (_,act) -> f act) cases ; + iter_opt f default | Lstaticraise (_,args) -> List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> @@ -313,6 +363,7 @@ let iter f = function | Lifused (v, e) -> f e + module IdentSet = Set.Make(struct type t = Ident.t @@ -340,7 +391,7 @@ let free_ids get l = | Lassign(id, e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstaticraise _ + | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ | Levent _ | Lifused _ -> () in free l; !fv @@ -358,6 +409,12 @@ let next_raise_count () = incr raise_count ; !raise_count +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count ; + !negative_raise_count + (* Anticipated staticraise, for guards *) let staticfail = Lstaticraise (0,[]) @@ -378,14 +435,19 @@ let rec patch_guarded patch = function (* Translate an access path *) -let rec transl_path = function +let rec transl_normal_path = function Pident id -> if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id | Pdot(p, s, pos) -> - Lprim(Pfield pos, [transl_path p]) + Lprim(Pfield pos, [transl_normal_path p]) | Papply(p1, p2) -> fatal_error "Lambda.transl_path" +(* Translation of value identifiers *) + +let transl_path ?(loc=Location.none) env path = + transl_normal_path (Env.normalize_path (Some loc) env path) + (* Compile a sequence of expressions *) let rec make_sequence fn = function @@ -414,11 +476,10 @@ let subst_lambda s lam = Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) - + sw_failaction = subst_opt sw.sw_failaction; }) + | Lstringswitch (arg,cases,default) -> + Lstringswitch + (subst arg,List.map subst_strcase cases,subst_opt default) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -433,6 +494,10 @@ let subst_lambda s lam = | Lifused (v, e) -> Lifused (v, subst e) and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) + and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam @@ -452,3 +517,34 @@ and negate_comparison = function | Ceq -> Cneq| Cneq -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> Lconst (Const_immstring + (String.capitalize + (Filename.chop_extension (Filename.basename file)))) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let reset () = + raise_count := 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 17da073c..0e038d93 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -41,7 +49,7 @@ type primitive = (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -137,6 +147,11 @@ and bigarray_layout = | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -170,6 +185,9 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch +(* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -199,10 +217,12 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function -val same: lambda -> lambda -> bool +(* Sharing key *) +val make_key: lambda -> lambda option + val const_unit: structured_constant val lambda_unit: lambda -val name_lambda: lambda -> (Ident.t -> lambda) -> lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val iter: (lambda -> unit) -> lambda -> unit @@ -210,7 +230,8 @@ module IdentSet: Set.S with type elt = Ident.t val free_variables: lambda -> IdentSet.t val free_methods: lambda -> IdentSet.t -val transl_path: Path.t -> lambda +val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda val subst_lambda: lambda Ident.tbl -> lambda -> lambda @@ -225,10 +246,19 @@ val negate_comparison : comparison -> comparison (* Get a new static failure ident *) val next_raise_count : unit -> int - +val next_negative_raise_count : unit -> int + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda + +val reset: unit -> unit diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 5c1d8726..8ab6cec8 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -21,6 +21,9 @@ open Lambda open Parmatch open Printf + +let dbg = false + (* See Peyton-Jones, ``The Implementation of functional programming languages'', chapter 5. *) (* @@ -38,6 +41,10 @@ open Printf - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -160,12 +167,24 @@ let make_default matcher env = let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (_, cstr,omegas,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> - p,args @ rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) + | Tpat_construct (_, cstr,omegas) -> + begin match cstr.cstr_tag with + | Cstr_extension _ -> + let nargs = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) + when List.length args = nargs -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | _ -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) + when cstr.cstr_tag=cstr'.cstr_tag -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + end | Tpat_constant cst -> (fun q rem -> match q.pat_desc with | Tpat_constant cst' when const_compare cst cst' = 0 -> @@ -412,6 +431,7 @@ let rec pretty_precompiled = function | PmOr x -> prerr_endline "++++ OR ++++" ; pretty_pm x.body ; + pretty_matrix x.or_matrix ; List.iter (fun (_,i,_,pm) -> eprintf "++ Handler %d ++\n" i ; @@ -428,67 +448,123 @@ let pretty_precompiled_res first nexts = -(* A slight attempt to identify semantically equivalent lambda-expressions *) -exception Not_simple +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switchs are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) -let raw_action l = try raw_rec [] l with Not_simple -> l +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_,_,e) -> as_simple_exit e + | _ -> None + + +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - match raw1, raw2 with - | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 - | _,_ -> raw1 = raw2 + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 with - | Not_simple -> false + | Exit -> false + +(* Nothing is kown about exception/extension patterns, + because of potential rebind *) +let rec exc_inside p = match p.pat_desc with + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true + | Tpat_any|Tpat_constant _|Tpat_var _ + | Tpat_construct (_,_,[]) + | Tpat_variant (_,None,_) + -> false + | Tpat_construct (_,_,ps) + | Tpat_tuple ps + | Tpat_array ps + -> exc_insides ps + | Tpat_variant (_, Some q,_) + | Tpat_alias (q,_,_) + | Tpat_lazy q + -> exc_inside q + | Tpat_record (lps,_) -> + List.exists (fun (_,_,p) -> exc_inside p) lps + | Tpat_or (p1,p2,_) -> exc_inside p1 || exc_inside p2 + +and exc_insides ps = List.exists exc_inside ps let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || - not (Parmatch.compats ps qs)) - l + if exc_insides ps then match l with [] -> true | _::_ -> false + else + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || + not (Parmatch.compats ps qs)) + l (* @@ -584,6 +660,16 @@ let rec what_is_cases cases = match cases with (* A few operation on default environments *) let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) +(* For extension matching, record no imformation in matrix *) +let as_matrix_omega cases = + get_mins le_pats + (List.map + (fun (ps,_) -> + match ps with + | [] -> assert false + | _::ps -> omega::ps) + cases) + let cons_default matrix raise_num default = match matrix with | [] -> default @@ -614,7 +700,7 @@ let rec extract_vars r p = match p.pat_desc with List.fold_left (fun r (_, _, p) -> extract_vars r p) r lpats -| Tpat_construct (_, _, pats,_) -> +| Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -658,13 +744,16 @@ let pm_free_variables {cases=cases} = (* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" let group_constant = function | {pat_desc= Tpat_constant _} -> true | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct _} -> true + | {pat_desc = Tpat_construct (_,_,_)} -> true | _ -> false and group_variant = function @@ -847,10 +936,74 @@ let rec split_or argo cls args def = do_split [] [] [] cls +(* Ultra-naive spliting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + { me = Pm {cases=yes; args=args; default=def;} ; + matrix = as_matrix_omega yes ; + top_default=def}, + k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl::yes) rem + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_exc cstr [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noexc [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + | _ -> assert false + + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let yes= List.rev yes in + let {me=next; matrix=matrix; top_default=def;},nexts = + split_exc (pat_as_constr p) [cl] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + else split_noexc (cl::yes) rem + | _ -> assert false in + + match cls with + | [] -> assert false + | (p::_,_ as cl)::rem -> + if group_constructor p then + split_exc (pat_as_constr p) [cl] rem + else + split_noexc [cl] rem + | _ -> assert false + and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> + split_naive cls args def k | _ -> let group = get_group ex_pat in @@ -956,12 +1109,21 @@ and dont_precompile_var args cls def k = matrix=as_matrix cls ; top_default=def},k +and is_exc p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 +| Tpat_alias (p,v,_) -> is_exc p +| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true +| _ -> false + and precompile_or argo cls ors args def k = match ors with | [] -> split_constr cls args def k | _ -> let rec do_cases = function | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in + let do_opt = not (is_exc orp) in + let others,rem = + if do_opt then get_equiv orp rem + else [],rem in let orpm = {cases = (patl, action):: @@ -971,7 +1133,7 @@ and precompile_or argo cls ors args def k = match ors with | _ -> assert false) others ; args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in + default = default_compat (if do_opt then orp else omega) def} in let vars = IdentSet.elements (IdentSet.inter @@ -984,17 +1146,19 @@ and precompile_or argo cls ors args def k = match ors with Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) in - let body,handlers = do_cases rem in + let do_optrec,body,handlers = do_cases rem in + do_opt && do_optrec, explode_or_pat argo new_patl mk_new_action body vars [] orp, - (([[orp]], or_num, vars , orpm):: handlers) + let mat = if do_opt then [[orp]] else [[omega]] in + ((mat, or_num, vars , orpm):: handlers) | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in + let b,new_ord,new_to_catch = do_cases rem in + b,cl::new_ord,new_to_catch + | [] -> true,[],[] in - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) + let do_opt,end_body, handlers = do_cases ors in + let matrix = (if do_opt then as_matrix else as_matrix_omega) (cls@ors) and body = {cases=cls@end_body ; args=args ; default=def} in {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; matrix=matrix ; @@ -1003,13 +1167,12 @@ and precompile_or argo cls ors args def k = match ors with let split_precompile argo pm = let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in -(* - if nexts <> [] || (match next with PmOr _ -> true | _ -> false) then begin + if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) + then begin prerr_endline "** SPLIT **" ; pretty_pm pm ; pretty_precompiled_res next nexts end ; -*) next, nexts @@ -1129,18 +1292,13 @@ let make_field_args binding_kind arg first_pos last_pos argl = in make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag | _ -> assert false let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem +| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem | _ -> assert false -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - - let matcher_constr cstr = match cstr.cstr_arity with | 0 -> let rec matcher_rec q rem = match q.pat_desc with @@ -1151,7 +1309,7 @@ let matcher_constr cstr = match cstr.cstr_arity with with | NoMatch -> matcher_rec p2 rem end - | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag -> rem | Tpat_any -> rem | _ -> raise NoMatch in @@ -1172,7 +1330,7 @@ let matcher_constr cstr = match cstr.cstr_arity with rem | _, _ -> assert false end - | Tpat_construct (_, cstr1, [arg],_) + | Tpat_construct (_, cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem | Tpat_any -> omega::rem | _ -> raise NoMatch in @@ -1180,7 +1338,7 @@ let matcher_constr cstr = match cstr.cstr_arity with | _ -> fun q rem -> match q.pat_desc with | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_, cstr1, args,_) + | Tpat_construct (_, cstr1, args) when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem | _ -> raise NoMatch @@ -1193,7 +1351,7 @@ let make_constr_matching p def ctx = function match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_exception _ -> + | Cstr_extension _ -> make_field_args Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; @@ -1324,7 +1482,7 @@ let get_mod_field modname field = lazy ( try let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial in + let env = Env.open_pers_signature modname Env.initial_safe_string in let p = try match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i @@ -1446,7 +1604,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1527,10 +1685,161 @@ let divide_array kind ctx pm = (make_array_matching kind) (=) get_key_array get_args_array ctx pm -(* To combine sub-matchings together *) + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let prim_string_notequal = + Pccall{prim_name = "caml_string_notequal"; + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} + +let prim_string_compare = + Pccall{prim_name = "caml_string_compare"; + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} + +let bind_sw arg k = match arg with +| Lvar _ -> k arg +| _ -> + let id = Ident.create "switch" in + Llet (Strict,id,arg,k (Lvar id)) + + +(* Sequential equality tests *) + +let make_string_test_sequence arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in + bind_sw arg + (fun arg -> + List.fold_right + (fun (s,lam) k -> + Lifthenelse + (Lprim + (prim_string_notequal, + [arg; Lconst (Const_immstring s)]), + k,lam)) + sw d) + +let rec split k xs = match xs with +| [] -> assert false +| x0::xs -> + if k <= 1 then [],x0,xs + else + let xs,y0,ys = split (k-2) xs in + x0::xs,y0,ys + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test arg lt eq gt = + Lifthenelse + (Lprim (Pintcomp Clt,[arg;zero_lam]),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq)) + +(* Dichotomic tree *) + + +let rec do_make_string_test_tree arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold+delta then + make_string_test_sequence arg sw d + else + let lt,(s,act),gt = split len sw in + bind_sw + (Lprim + (prim_string_compare, + [arg; Lconst (Const_immstring s)];)) + (fun r -> + tree_way_test r + (do_make_string_test_tree arg lt delta d) + act + (do_make_string_test_tree arg gt delta d)) + +(* Entry point *) +let expand_stringswitch arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, includint potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Recontruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = match sw with + | []|[_] -> sw + | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) + else p1::uniq_lambda_list sw1 let sort_lambda_list l = - List.sort (fun (x,_) (y,_) -> const_compare x y) l + let l = + List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + uniq_lambda_list l let rec cut n l = if n = 0 then [],l @@ -1556,8 +1865,12 @@ let rec do_tests_nofail tst arg = function act) let make_test_sequence fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Praise then + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list else match fail with | None -> do_tests_nofail tst arg const_lambda_list @@ -1568,18 +1881,10 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), make_test_sequence list1, make_test_sequence list2) - in make_test_sequence (sort_lambda_list const_lambda_list) - - -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) - + in + hs (make_test_sequence const_lambda_list) -let prim_string_notequal = - Pccall{prim_name = "caml_string_notequal"; - prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false} - let rec explode_inter offset i j act k = if i <= j then explode_inter offset i (j-1) act ((j-offset,act)::k) @@ -1587,7 +1892,7 @@ let rec explode_inter offset i j act k = k let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in + let vals = Array.make (Array.length acts) 0 in for i=Array.length cases-1 downto 0 do let l,h,act = cases.(i) in vals.(act) <- h - l + 1 + vals.(act) @@ -1620,65 +1925,6 @@ let as_int_list cases acts = (if default >= 0 then Some acts.(default) else None) -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - -let full sw = - List.length sw.sw_consts = sw.sw_numconsts && - List.length sw.sw_blocks = sw.sw_numblocks - -let make_switch (arg,sw) = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen l = match l with - | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) - module SArg = struct type primitive = Lambda.primitive @@ -1695,6 +1941,7 @@ module SArg = struct let make_offset arg n = match n with | 0 -> arg | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1702,13 +1949,89 @@ module SArg = struct let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - + let make_const i = Lconst (Const_base (Const_int i)) let make_isout h arg = Lprim (Pisout, [h ; arg]) let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch @@ -1725,7 +2048,16 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store tag act = + let i = store.act_store act in +(* + Printlambda.lambda Format.str_formatter act ; + eprintf "STORE [%s] %i %s\n" tag i (Format.flush_str_formatter ()) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1733,7 +2065,7 @@ let as_interval_canfail fail low high l = else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1741,14 +2073,18 @@ let as_interval_canfail fail low high l = (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: @@ -1757,7 +2093,7 @@ let as_interval_canfail fail low high l = let init_rec = function | [] -> [] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1766,12 +2102,12 @@ let as_interval_canfail fail low high l = else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in let rec i_rec cur_low cur_high cur_act = function | [] -> @@ -1789,7 +2125,7 @@ let as_interval_nofail l = i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -1807,10 +2143,10 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions + Switcher.zyva edges arg cases actions let exists_ctx ok ctx = @@ -1920,6 +2256,11 @@ let mk_failaction_neg partial ctx def = match partial with (* Conforme a l'article et plus simple qu'avant *) and mk_failaction_pos partial seen ctx defs = + if dbg then begin + prerr_endline "**POS**" ; + pretty_def defs ; + () + end ; let rec scan_def env to_test defs = match to_test,defs with | ([],_)|(_,[]) -> List.fold_left @@ -1960,19 +2301,27 @@ let combine_constant arg cst partial ctx def let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> - make_test_sequence - fail prim_string_notequal Praise arg const_lambda_list +(* Note as the bytecode compiler may resort to dichotmic search, + the clauses of strinswitch are sorted with duplicate removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c,act) -> match c with + | Const_string (s,_) -> s,act + | _ -> assert false) + const_lambda_list in + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail)) | Const_float _ -> make_test_sequence fail @@ -2010,32 +2359,61 @@ let split_cases tag_lambda_list = sort_int_lambda_list const, sort_int_lambda_list nonconst +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) + (* Special cases for extensions *) let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = - let default, tests = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = match fail with | None -> - begin match tag_lambda_list with - | (_, act)::rem -> act,rem + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts | _ -> assert false end - | Some fail -> fail, tag_lambda_list in - List.fold_right - (fun (ex, act) rem -> - match ex with - | Cstr_exception (path, _) -> - Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Pfield 0, [arg]); transl_path path]), - act, rem) - | _ -> assert false) - tests default in + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lvar tag; + transl_path ex_pat.pat_env path]), + act, rem)) + nonconsts + default + in + Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests) + in + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [arg; transl_path ex_pat.pat_env path]), + act, rem)) + consts + nonconst_lambda + in lambda1, jumps_union local_jumps total1 end else begin (* Regular concrete type *) @@ -2059,22 +2437,22 @@ let combine_constructor arg ex_pat cstr partial ctx def | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + call_switcher None arg 0 (n-1) consts | (n, _, _, _) -> match same_actions nonconsts with | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = None} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) None arg 0 (n-1) consts, act) in @@ -2084,20 +2462,16 @@ let combine_constructor arg ex_pat cstr partial ctx def let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list let call_switcher_variant_constr fail arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = @@ -2161,7 +2535,6 @@ let combine_array arg kind partial ctx def let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind @@ -2280,10 +2653,6 @@ let rec approx_present v = function | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond @@ -2385,8 +2754,6 @@ let arg_to_var arg cls = match arg with Output: a lambda term, a jump summary {..., exit number -> context, .. } *) -let dbg = false - let rec compile_match repr partial ctx m = match m with | { cases = [] } -> comp_exit ctx m | { cases = ([], action) :: rem } -> @@ -2444,7 +2811,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with divide_constant (combine_constant arg cst partial) ctx pm - | Tpat_construct (_, cstr, _, _) -> + | Tpat_construct (_, cstr, _) -> compile_test (compile_match repr partial) partial divide_constructor (combine_constructor arg pat cstr partial) @@ -2507,7 +2874,7 @@ let find_in_pat pred = begin match p.pat_desc with | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps,_) | Tpat_array ps -> + | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> List.exists find_rec ps | Tpat_record (lpats,_) -> List.exists @@ -2604,10 +2971,10 @@ let compile_matching loc repr handler_fun arg pat_act_list partial = let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_match_failure; + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), + [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))])]) @@ -2616,7 +2983,8 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None (fun () -> Lprim(Praise, [param])) + compile_matching Location.none None + (fun () -> Lprim(Praise Raise_reraise, [param])) param pat_act_list Partial let for_let loc param pat body = diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 5c8577b2..88002e05 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -15,6 +15,8 @@ open Typedtree open Lambda + +(* Entry points to match compiler *) val for_function: Location.t -> int ref option -> lambda -> (pattern * lambda) list -> partial -> lambda @@ -34,8 +36,8 @@ exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda +(* Expand stringswitch to string test tree *) +val expand_stringswitch: + lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index 35d87766..f7711ff1 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -12,13 +12,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_resize : bytes -> int -> bytes = "caml_static_resize" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index a8ef5272..cb3565dc 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -14,13 +14,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" -external static_resize : string -> int -> string = "caml_static_resize" +external static_resize : bytes -> int -> bytes = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml index a5cd7e05..43d8d360 100644 --- a/bytecomp/printinstr.ml +++ b/bytecomp/printinstr.ml @@ -67,7 +67,7 @@ let instruction ppf = function | Kboolnot -> fprintf ppf "\tboolnot" | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl | Kpoptrap -> fprintf ppf "\tpoptrap" - | Kraise -> fprintf ppf "\traise" + | Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k) | Kcheck_signals -> fprintf ppf "\tcheck_signals" | Kccall(s, n) -> fprintf ppf "\tccall %s, %i" s n diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 65316700..d528a357 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -20,7 +20,7 @@ open Lambda let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> fprintf ppf "%C" c - | Const_base(Const_string s) -> fprintf ppf "%S" s + | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f | Const_base(Const_int32 n) -> fprintf ppf "%lil" n @@ -87,11 +87,19 @@ let record_rep ppf r = | Record_float -> fprintf ppf "float" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -105,7 +113,7 @@ let primitive ppf = function | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise -> fprintf ppf "raise" + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" @@ -229,6 +237,7 @@ let primitive ppf = function else fprintf ppf "bigarray.array1.set64" | Pbswap16 -> fprintf ppf "bswap16" | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" let rec lam ppf = function | Lvar id -> @@ -255,12 +264,15 @@ let rec lam ppf = function fprintf ppf ")" in fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body | Llet(str, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in let rec letbody = function | Llet(str, id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s@ %a@]" + Ident.print id (kind str) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> @@ -296,11 +308,26 @@ let rec lam ppf = function if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[default:@ %a@]" lam l end in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" (match sw.sw_failaction with None -> "switch*" | _ -> "switch") lam larg switch sw + | Lstringswitch(arg, cases, default) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index e60bb6d1..fd3d21c1 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -51,9 +51,13 @@ let rec eliminate_ref id = function sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) + | Lstringswitch(e, sw, default) -> + Lstringswitch + (eliminate_ref id e, + List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, + Misc.may_map (eliminate_ref id) default) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -115,6 +119,15 @@ let simplify_exits lam = count l; List.iter (fun (_, l) -> count l) sw.sw_consts; List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstringswitch(l, sw, d) -> + count l; + List.iter (fun (_, l) -> count l) sw; + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -138,10 +151,7 @@ let simplify_exits lam = | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l + | Lassign(v, l) -> count l | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -209,13 +219,15 @@ let simplify_exits lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch(l,sw,d) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -241,17 +253,10 @@ let simplify_exits lam = | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 - | 1 -> + | 1 when i >= 0 -> Hashtbl.add subst i (xs,simplif l2) ; simplif l1 | _ -> @@ -361,6 +366,17 @@ let simplify_lets lam = count bv l; List.iter (fun (_, l) -> count bv l) sw.sw_consts; List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstringswitch(l, sw, d) -> + count bv l ; + List.iter (fun (_, l) -> count bv l) sw ; + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end | Lstaticraise (i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 @@ -453,13 +469,15 @@ let simplify_lets lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch (l,sw,d) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -520,7 +538,14 @@ let rec emit_tail_infos is_tail lambda = | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction + | Lstringswitch (lam, sw, d) -> + emit_tail_infos false lam; + List.iter + (fun (_,lam) -> emit_tail_infos is_tail lam) + sw ; + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee1..da9a48f1 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} - -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +100,15 @@ module type S = type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -196,7 +248,7 @@ let case_append c1 c2 = let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +277,7 @@ let case_append c1 c2 = done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +287,7 @@ let case_append c1 c2 = done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -489,77 +541,77 @@ and enum top cases = end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin let w,c = opt_count false cases in @@ -579,31 +631,31 @@ and enum top cases = if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +665,17 @@ and enum top cases = and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -676,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j = let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -697,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j = tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j = let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -768,13 +820,13 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -787,12 +839,31 @@ let zyva (low,high) konst arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +875,7 @@ and test_sequence konst arg cases actions = pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 69fc800d..53fd9974 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -17,9 +17,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +65,7 @@ module type S = (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +76,15 @@ module type S = NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +96,18 @@ module type S = module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 63374f82..1cc3a531 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -96,7 +96,7 @@ let require_primitive name = if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -134,13 +134,17 @@ let output_primitive_table outchan = let init () = (* Enter the predefined exceptions *) - Array.iter - (fun name -> + Array.iteri + (fun i name -> let id = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(0, [Const_base(Const_string name)]) in + let cst = Const_block(Obj.object_tag, + [Const_base(Const_string (name, None)); + Const_base(Const_int (-i-1)) + ]) + in literal_table := (c, cst) :: !literal_table) Runtimedef.builtin_exceptions; (* Initialize the known C primitives *) @@ -194,7 +198,7 @@ let gen_patch_object str_set buff patchlist = gen_patch_int str_set buff pos (num_of_prim name)) patchlist -let patch_object = gen_patch_object String.unsafe_set +let patch_object = gen_patch_object Bytes.unsafe_set let ls_patch_object = gen_patch_object LongString.set (* Translate structured constants *) @@ -202,7 +206,7 @@ let ls_patch_object = gen_patch_object LongString.set let rec transl_const = function Const_base(Const_int i) -> Obj.repr i | Const_base(Const_char c) -> Obj.repr c - | Const_base(Const_string s) -> Obj.repr s + | Const_base(Const_string (s, _)) -> Obj.repr s | Const_base(Const_float f) -> Obj.repr (float_of_string f) | Const_base(Const_int32 i) -> Obj.repr i | Const_base(Const_int64 i) -> Obj.repr i @@ -222,7 +226,7 @@ let rec transl_const = function (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -296,7 +300,8 @@ let init_toplevel () = Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); @@ -372,3 +377,15 @@ let report_error ppf = function fprintf ppf "Cannot find or execute the runtime system %s" s | Uninitialized_global s -> fprintf ppf "The value of the global `%s' is not yet computed" s + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + global_table := empty_numtable; + literal_table := []; + c_prim_table := empty_numtable diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index e3c33d23..ffc878bf 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -17,7 +17,7 @@ open Cmo_format (* Functions for batch linking *) val init: unit -> unit -val patch_object: string -> (reloc_info * int) list -> unit +val patch_object: bytes -> (reloc_info * int) list -> unit val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array @@ -29,7 +29,7 @@ val data_primitive_names: unit -> string (* Functions for the toplevel *) -val init_toplevel: unit -> (string * Digest.t) list +val init_toplevel: unit -> (string * Digest.t option) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool @@ -57,3 +57,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index ec40912c..0fb68457 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -109,6 +109,15 @@ let create_object cl obj init = [obj; Lvar obj'; Lvar cl])))) end +let name_pattern default p = + match p.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias(p, id, _) -> id + | _ -> Ident.create default + +let normalize_cl_path cl path = + Env.normalize_path (Some cl.cl_loc) cl.cl_env path + let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> @@ -118,7 +127,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = match envs with None -> [] | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] in - ((envs, (obj_init, path)::inh_init), + ((envs, (obj_init, normalize_cl_path cl path) + ::inh_init), mkappl(Lvar obj_init, env @ [obj])) | Tcl_structure str -> create_object cl_table obj (fun obj -> @@ -126,18 +136,18 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = List.fold_right (fun field (inh_init, obj_init, has_init) -> match field.cf_desc with - Tcf_inher (_, cl, _, _, _) -> + Tcf_inherit (_, cl, _, _, _) -> let (inh_init, obj_init') = build_object_init cl_table (Lvar obj) [] inh_init (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Tcf_val (_, _, _, id, Tcfk_concrete exp, _) -> + | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_meth _ | Tcf_val _ | Tcf_constr _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) - | Tcf_init _ -> + | Tcf_initializer _ -> (inh_init, obj_init, true) ) str.cstr_fields @@ -156,7 +166,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = in (inh_init, let build params rem = - let param = name_pattern "param" [pat, ()] in + let param = name_pattern "param" pat in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) @@ -247,7 +257,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Tcl_ident ( path, _, _) -> begin match inh_init with (obj_init, path')::inh_init -> - let lpath = transl_path path in + let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, Llet (Strict, obj_init, mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: @@ -262,38 +272,42 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = List.fold_right (fun field (inh_init, cl_init, methods, values) -> match field.cf_desc with - Tcf_inher (_, cl, _, vals, meths) -> + Tcf_inherit (_, cl, _, vals, meths) -> let cl_init = output_methods cla methods cl_init in let inh_init, cl_init = build_class_init cla false (vals, meths_super cla str.cstr_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Tcf_val (name, _, _, id, exp, over) -> - let values = if over then values else (name, id) :: values in + | Tcf_val (name, _, id, _, over) -> + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) - | Tcf_meth (_, _, _, Tcfk_virtual _, _) - | Tcf_constr _ + | Tcf_method (_, _, Tcfk_virtual _) + | Tcf_constraint _ -> (inh_init, cl_init, methods, values) - | Tcf_meth (name, _, _, Tcfk_concrete exp, over) -> + | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> let met_code = msubst true (transl_exp exp) in let met_code = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) - let met = Ident.create ("method_" ^ name) in + let met = Ident.create ("method_" ^ name.txt) in [Llet(Strict, met, List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, - Lvar (Meths.find name str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) - | Tcf_init exp -> + | Tcf_initializer exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), - methods, values)) + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) str.cstr_fields (inh_init, cl_init, [], []) in @@ -325,8 +339,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with Tcl_ident (path, _, _), (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + assert (Path.same (normalize_cl_path cl path) path'); + let lpath = transl_normal_path path' in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in @@ -392,11 +406,11 @@ let rec transl_class_rebind obj_init cl vf = try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit with Not_found -> raise Exit end; - (path, obj_init) + (normalize_cl_path cl path, obj_init) | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = - let param = name_pattern "param" [pat, ()] in + let param = name_pattern "param" pat in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) @@ -416,7 +430,7 @@ let rec transl_class_rebind obj_init cl vf = let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Cty_constr(path', _, _) when Path.same path path' -> () - | Cty_fun (_, _, cty) -> check_constraint cty + | Cty_arrow (_, _, cty) -> check_constraint cty | _ -> raise Exit in check_constraint cl.cl_type; @@ -440,7 +454,7 @@ let transl_class_rebind ids cl vf = if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in - if id then transl_path path else + if id then transl_normal_path path else let cla = Ident.create "class" and new_init = Ident.create "new_init" @@ -450,7 +464,7 @@ let transl_class_rebind ids cl vf = Llet( Strict, new_init, lfunction [obj_init] obj_init', Llet( - Alias, cla, transl_path path, + Alias, cla, transl_normal_path path, Lprim(Pmakeblock(0, Immutable), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] @@ -735,7 +749,7 @@ let transl_class ids cl_id pub_meths cl vflag = Lprim(Pmakeblock(0, Immutable), menv :: List.map (fun id -> Lvar id) !new_ids_init) and linh_envs = - List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p])) (List.rev inh_init) in let make_envs lam = @@ -752,7 +766,7 @@ let transl_class ids cl_id pub_meths cl vflag = List.filter (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in let inh_keys = - List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, Lfunction(Curried, [cla], def_ids cla cl_init), lam) @@ -798,7 +812,7 @@ let transl_class ids cl_id pub_meths cl vflag = (* let cl_id = ci.ci_id_class in (* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length (fst ci.ci_params) in + let _arity = List.length ci.ci_params in let pub_meths = m in let cl = ci.ci_expr in let vflag = vf in @@ -820,3 +834,12 @@ let report_error ppf = function | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 36b79daa..876abaa9 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -146,7 +146,9 @@ let primitives_table = create_hashtable 57 [ "%setfield0", Psetfield(0, true); "%makeblock", Pmakeblock(0, Immutable); "%makemutable", Pmakeblock(0, Mutable); - "%raise", Praise; + "%raise", Praise Raise_regular; + "%reraise", Praise Raise_reraise; + "%raise_notrace", Praise Raise_notrace; "%sequand", Psequand; "%sequor", Psequor; "%boolnot", Pnot; @@ -309,6 +311,7 @@ let primitives_table = create_hashtable 57 [ "%bswap_int32", Pbbswap(Pint32); "%bswap_int64", Pbbswap(Pint64); "%bswap_native", Pbbswap(Pnativeint); + "%int_as_pointer", Pint_as_pointer; ] let prim_makearray = @@ -323,6 +326,11 @@ let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -333,10 +341,10 @@ let transl_prim loc prim args = simplify_constant_constructor) = Hashtbl.find comparisons_table prim_name in begin match args with - [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}] + [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] when simplify_constant_constructor -> intcomp - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; arg2] when simplify_constant_constructor -> intcomp | [arg1; {exp_desc = Texp_variant(_, None)}] @@ -402,10 +410,20 @@ let transl_primitive loc p = with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -495,7 +513,7 @@ let extract_float = function let rec name_pattern default = function [] -> Ident.create default - | (p, e) :: rem -> + | {c_lhs=p; _} :: rem -> match p.pat_desc with Tpat_var (id, _) -> id | Tpat_alias(p, id, _) -> id @@ -503,24 +521,29 @@ let rec name_pattern default = function (* Push the default values under the functional abstractions *) -let rec push_defaults loc bindings pat_expr_list partial = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] -> +let rec push_defaults loc bindings cases partial = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [pat, {exp with exp_desc = Texp_function(l, pl, partial)}] - | [pat, {exp_desc = Texp_let - (Default, cases, ({exp_desc = Texp_function _} as e2))}] -> - push_defaults loc (cases :: bindings) [pat, e2] partial - | [pat, exp] -> + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{txt="#default"},_]; + exp_desc = Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [case] -> let exp = List.fold_left - (fun exp cases -> - {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) - exp bindings + (fun exp binds -> + {exp with exp_desc = Texp_let(Nonrecursive, binds, exp)}) + case.c_rhs bindings in - [pat, exp] - | (pat, exp) :: _ when bindings <> [] -> - let param = name_pattern "param" pat_expr_list in + [{case with c_rhs=exp}] + | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + let param = name_pattern "param" cases in let name = Ident.name param in let exp = { exp with exp_loc = loc; exp_desc = @@ -528,14 +551,17 @@ let rec push_defaults loc bindings pat_expr_list partial = ({exp with exp_type = pat.pat_type; exp_desc = Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), {val_type = pat.pat_type; val_kind = Val_reg; + val_attributes = []; Types.val_loc = Location.none; })}, - pat_expr_list, partial) } + cases, [], partial) } in push_defaults loc bindings - [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> - pat_expr_list + cases (* Insertion of debugging events *) @@ -581,11 +607,11 @@ let primitive_is_ccall = function let assert_failed exp = let (fname, line, char) = Location.get_pos_info exp.exp_loc.Location.loc_start in - Lprim(Praise, [event_after exp + Lprim(Praise Raise_regular, [event_after exp (Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_assert_failure; + [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))]))]) ;; @@ -597,6 +623,8 @@ let rec cut n l = (* Translation of expressions *) +let try_ids = Hashtbl.create 8 + let rec transl_exp e = let eval_once = (* Whether classes for immediate objects must be cached *) @@ -627,7 +655,7 @@ and transl_exp0 e = | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> - transl_path path + transl_path ~loc:e.exp_loc e.exp_env path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" | Texp_constant cst -> Lconst(Const_base cst) @@ -675,8 +703,23 @@ and transl_exp0 e = (Warnings.Deprecated "operator (or); you should use (||) instead"); let prim = transl_prim e.exp_loc p args in match (prim, args) with - (Praise, [arg1]) -> - wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) + (Praise k, [arg1]) -> + let targ = List.hd argl in + let k = + match k, targ with + | Raise_regular, Lvar id + when Hashtbl.mem try_ids id -> + Raise_reraise + | _ -> + k + in + wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> @@ -688,16 +731,12 @@ and transl_exp0 e = end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) - | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> - Matching.for_multiple_match e.exp_loc - (transl_list argl) (transl_cases pat_expr_list) partial - | Texp_match(arg, pat_expr_list, partial) -> - Matching.for_function e.exp_loc None - (transl_exp arg) (transl_cases pat_expr_list) partial + | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try(body, pat_expr_list) -> let id = name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases pat_expr_list)) + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) | Texp_tuple el -> let ll = transl_list el in begin try @@ -705,7 +744,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end - | Texp_construct(_, cstr, args, _) -> + | Texp_construct(_, cstr, args) -> let ll = transl_list args in begin match cstr.cstr_tag with Cstr_constant n -> @@ -716,8 +755,12 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception (path, _) -> - Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) + | Cstr_extension(path, is_const) -> + if is_const then + transl_path e.exp_env path + else + Lprim(Pmakeblock(0, Immutable), + transl_path e.exp_env path :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -782,10 +825,6 @@ and transl_exp0 e = | Texp_for(param, _, low, high, dir, body) -> Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_exp body)) - | Texp_when(cond, body) -> - event_before cond - (Lifthenelse(transl_exp cond, event_before body (transl_exp body), - staticfail)) | Texp_send(_, _, Some exp) -> transl_exp exp | Texp_send(expr, met, None) -> let obj = transl_exp expr in @@ -798,16 +837,18 @@ and transl_exp0 e = Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam - | Texp_new (cl, _, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]), + [lambda_unit], Location.none) | Texp_instvar(path_self, path, _) -> - Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) + Lprim(Parrayrefu Paddrarray, + [transl_normal_path path_self; transl_normal_path path]) | Texp_setinstvar(path_self, path, _, expr) -> - transl_setinstvar (transl_path path_self) path expr + transl_setinstvar (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self], + Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self], Location.none), List.fold_right (fun (path, _, expr) rem -> @@ -818,11 +859,12 @@ and transl_exp0 e = Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> + assert_failed e | Texp_assert (cond) -> if !Clflags.noassert then lambda_unit else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_assertfalse -> assert_failed e | Texp_lazy e -> (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would @@ -833,7 +875,7 @@ and transl_exp0 e = ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) | Texp_function(_, _, _) - | Texp_construct (_, {cstr_arity = 0}, _, _) + | Texp_construct (_, {cstr_arity = 0}, _) -> transl_exp e | Texp_constant(Const_float _) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) @@ -859,7 +901,6 @@ and transl_exp0 e = || has_base_type e Predef.path_exn || has_base_type e Predef.path_array || has_base_type e Predef.path_list - || has_base_type e Predef.path_format6 || has_base_type e Predef.path_option || has_base_type e Predef.path_nativeint || has_base_type e Predef.path_int32 @@ -871,7 +912,7 @@ and transl_exp0 e = (* other cases compile to a lazy block holding a function *) | _ -> let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in - Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn]) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in @@ -880,18 +921,43 @@ and transl_exp0 e = { cl_desc = Tcl_structure cs; cl_loc = e.exp_loc; cl_type = Cty_signature cty; - cl_env = e.exp_env } + cl_env = e.exp_env; + cl_attributes = []; + } and transl_list expr_list = List.map transl_exp expr_list -and transl_cases pat_expr_list = - List.map - (fun (pat, expr) -> (pat, event_before expr (transl_exp expr))) - pat_expr_list +and transl_guard guard rhs = + let expr = event_before rhs (transl_exp rhs) in + match guard with + | None -> expr + | Some cond -> + event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) + +and transl_case {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard c_guard c_rhs + +and transl_cases cases = + List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + match c_lhs.pat_desc with + | Tpat_var (id, _) + | Tpat_alias (_, id, _) -> + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + (fun () -> Hashtbl.remove try_ids id) + | _ -> + c_lhs, transl_guard c_guard c_rhs + +and transl_cases_try cases = + List.map transl_case_try cases and transl_tupled_cases patl_expr_list = - List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list + List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) + patl_expr_list and transl_apply lam sargs loc = let lapply funct args = @@ -943,56 +1009,58 @@ and transl_apply lam sargs loc = in build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) -and transl_function loc untuplify_fn repr partial pat_expr_list = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)] +and transl_function loc untuplify_fn repr partial cases = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function(_, pl,partial')} as exp}] when Parmatch.fluid pat -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in let ((_, params), body) = transl_function exp.exp_loc false repr partial' pl in ((Curried, param :: params), Matching.for_function loc None (Lvar param) [pat, body] partial) - | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn -> + | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> begin try let size = List.length pl in let pats_expr_list = List.map - (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr)) - pat_expr_list in + (fun {c_lhs; c_guard; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + cases in let params = List.map (fun p -> Ident.create "param") pl in ((Tupled, params), Matching.for_tupled_function loc params (transl_tupled_cases pats_expr_list) partial) with Matching.Cannot_flatten -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) end | _ -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) and transl_let rec_flag pat_expr_list body = match rec_flag with - Nonrecursive | Default -> + Nonrecursive -> let rec transl = function [] -> body - | (pat, expr) :: rem -> + | {vb_pat=pat; vb_expr=expr} :: rem -> Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem) in transl pat_expr_list | Recursive -> let idlist = List.map - (fun (pat, expr) -> match pat.pat_desc with + (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var (id,_) -> id | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in - let transl_case (pat, expr) id = + let transl_case {vb_pat=pat; vb_expr=expr} id = let lam = transl_exp expr in if not (check_recursive_lambda idlist lam) then raise(Error(expr.exp_loc, Illegal_letrec_expr)); @@ -1001,7 +1069,7 @@ and transl_let rec_flag pat_expr_list body = and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), - [self; transl_path var; transl_exp expr]) + [self; transl_normal_path var; transl_exp expr]) and transl_record all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in @@ -1010,7 +1078,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in + let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in begin match opt_init_expr with None -> () @@ -1068,6 +1136,34 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = end end +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = name_pattern "val" pat_expr_list in + static_catch [transl_exp arg] [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + + (* Wrapper for class compilation *) (* @@ -1081,15 +1177,6 @@ let transl_let rec_flag pat_expr_list body = (transl_let rec_flag pat_expr_list) body *) -(* Compile an exception definition *) - -let transl_exception id path decl = - let name = - match path with - None -> Ident.name id - | Some p -> Path.name p in - Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))]) - (* Error report *) open Format @@ -1106,3 +1193,12 @@ let report_error ppf = function "Ancestor names can only be used to select inherited methods" | Unknown_builtin_primitive prim_name -> fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index f766cdcf..70f700fc 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -17,16 +17,11 @@ open Asttypes open Typedtree open Lambda -val name_pattern: string -> (pattern * 'a) list -> Ident.t - val transl_exp: expression -> lambda val transl_apply: lambda -> (label * expression option * optional) list -> Location.t -> lambda -val transl_let: - rec_flag -> (pattern * expression) list -> lambda -> lambda +val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> lambda -val transl_exception: - Ident.t -> Path.t option -> exception_declaration -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 3b94a915..dc7d2d7a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -27,30 +27,92 @@ open Translclass type error = Circular_dependency of Ident.t + exception Error of Location.t * error +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) + +let prim_set_oo_id = + Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false} + +let transl_extension_constructor env path ext = + let name = + match path with + None -> Ident.name ext.ext_id + | Some p -> Path.name p + in + match ext.ext_kind with + Text_decl(args, ret) -> + Lprim(prim_set_oo_id, + [Lprim(Pmakeblock(Obj.object_tag, Mutable), + [Lconst(Const_base(Const_string (name,None))); + Lconst(Const_base(Const_int 0))])]) + | Text_rebind(path, lid) -> + transl_path ~loc:ext.ext_loc env path + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, ext.ext_id, lam, body)) + tyext.tyext_constructors + body + (* Compile a coercion *) -let rec apply_coercion restr arg = +let rec apply_coercion strict restr arg = match restr with Tcoerce_none -> arg - | Tcoerce_structure pos_cc_list -> - name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list)) + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let lam = + Lprim(Pmakeblock(0, Immutable), + List.map (apply_coercion_field id) pos_cc_list) in + let fv = free_variables lam in + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias,id'', + apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in - name_lambda arg (fun id -> + name_lambda strict arg (fun id -> Lfunction(Curried, [param], - apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], + apply_coercion Strict cc_res + (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)], Location.none)))) | Tcoerce_primitive p -> transl_primitive Location.none p + | Tcoerce_alias (path, cc) -> + name_lambda strict arg + (fun id -> apply_coercion Alias cc (transl_normal_path path)) and apply_coercion_field id (pos, cc) = - apply_coercion cc (Lprim(Pfield pos, [Lvar id])) + apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id])) (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -60,21 +122,42 @@ let rec compose_coercions c1 c2 = match (c1, c2) with (Tcoerce_none, c2) -> c2 | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure pc1, Tcoerce_structure pc2) -> + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in Tcoerce_structure (List.map (function (p1, Tcoerce_primitive p) -> (p1, Tcoerce_primitive p) | (p1, c1) -> let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) - pc1) + pc1, + ids1 @ ids2) | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> Tcoerce_functor(compose_coercions arg2 arg1, compose_coercions res1 res2) + | (c1, Tcoerce_alias (path, c2)) -> + Tcoerce_alias (path, compose_coercions c1 c2) | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c2; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -83,24 +166,11 @@ let record_primitive = function primitive_declarations := p :: !primitive_declarations | _ -> () -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming exceptions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) - (* Utilities for compiling "module rec" definitions *) let mod_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name)) Env.empty)) with Not_found -> @@ -109,7 +179,7 @@ let mod_prim name = let undefined_location loc = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)])) @@ -118,6 +188,8 @@ let init_shape modl = match Mtype.scrape env mty with Mty_ident _ -> raise Not_found + | Mty_alias _ -> + Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) | Mty_functor(id, arg, res) -> @@ -135,12 +207,12 @@ let init_shape modl = | _ -> raise Not_found in init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> - init_shape_struct (Env.add_type id tdecl env) rem - | Sig_exception(id, edecl) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext(id, ext, _) :: rem -> raise Not_found - | Sig_module(id, mty, _) :: rem -> - init_shape_mod env mty :: - init_shape_struct (Env.add_module id mty env) rem + | Sig_module(id, md, _) :: rem -> + init_shape_mod env md.md_type :: + init_shape_struct (Env.add_module_declaration id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class(id, cdecl, _) :: rem -> @@ -166,7 +238,7 @@ let reorder_rec_bindings bindings = and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with @@ -222,22 +294,22 @@ let eval_rec_bindings bindings cont = let compile_recmodule compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings - (List.map - (fun ( id, _, _, modl) -> - (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) - bindings)) + (List.map + (fun {mb_id=id; mb_expr=modl; _} -> + (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) + bindings)) cont (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. + correspond to a run-time value: values, extensions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -245,9 +317,13 @@ let rec bound_value_identifiers = function (* Compile a module expression *) let rec transl_module cc rootpath mexp = + match mexp.mod_type with + Mty_alias _ -> apply_coercion Alias cc lambda_unit + | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion cc (transl_path path) + apply_coercion StrictOpt cc + (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> transl_struct [] cc rootpath str | Tmod_functor( param, _, mty, body) -> @@ -260,20 +336,21 @@ let rec transl_module cc rootpath mexp = | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in Lfunction(Curried, [param'], - Llet(Alias, param, apply_coercion ccarg (Lvar param'), + Llet(Alias, param, + apply_coercion Alias ccarg (Lvar param'), transl_module ccres bodypath body)) | _ -> fatal_error "Translmod.transl_module") cc | Tmod_apply(funct, arg, ccarg) -> oo_wrap mexp.mod_env true - (apply_coercion cc) + (apply_coercion Strict cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg], mexp.mod_loc)) | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - apply_coercion cc (Translcore.transl_exp arg) + apply_coercion Strict cc (Translcore.transl_exp arg) and transl_struct fields cc rootpath str = transl_structure fields cc rootpath str.str_items @@ -284,53 +361,58 @@ and transl_structure fields cc rootpath = function Tcoerce_none -> Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), + (*List.fold_left + (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*) + (Lprim(Pmakeblock(0, Immutable), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion cc (Lvar v.(pos))) - pos_cc_list) + | _ -> apply_coercion Strict cc (Lvar v.(pos))) + pos_cc_list)) + (*id_pos_list*) | _ -> fatal_error "Translmod.transl_structure" end | item :: rem -> match item.str_desc with - | Tstr_eval expr -> + | Tstr_eval (expr, _) -> Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) | Tstr_value(rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in transl_let rec_flag pat_expr_list (transl_structure ext_fields cc rootpath rem) - | Tstr_primitive(id, _, descr) -> + | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure fields cc rootpath rem | Tstr_type(decls) -> transl_structure fields cc rootpath rem - | Tstr_exception( id, _, decl) -> - Llet(Strict, id, transl_exception id (field_path rootpath id) decl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, _) -> - Llet(Strict, id, transl_path path, + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + transl_type_extension item.str_env rootpath tyext + (transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + Llet(Strict, id, transl_extension_constructor item.str_env path ext, transl_structure (id :: fields) cc rootpath rem) - | Tstr_module( id, _, modl) -> - Llet(Strict, id, - transl_module Tcoerce_none (field_path rootpath id) modl, + | Tstr_module mb -> + let id = mb.mb_id in + Llet(pure_module mb.mb_expr, id, + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr, transl_structure (id :: fields) cc rootpath rem) | Tstr_recmodule bindings -> let ext_fields = - List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in compile_recmodule (fun id modl -> transl_module Tcoerce_none (field_path rootpath id) modl) bindings (transl_structure ext_fields cc rootpath rem) - | Tstr_modtype(id, _, decl) -> - transl_structure fields cc rootpath rem - | Tstr_open _ -> - transl_structure fields cc rootpath rem | Tstr_class cl_list -> let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in Lletrec(List.map @@ -339,11 +421,10 @@ and transl_structure fields cc rootpath = function let cl = ci.ci_expr in (id, transl_class ids id meths cl vf )) cl_list, - transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_class_type cl_list -> - transl_structure fields cc rootpath rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -351,9 +432,21 @@ and transl_structure fields cc rootpath = function | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, + Llet(pure_module modl, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_structure fields cc rootpath rem + +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict + (* Update forward declaration in Translcore *) let _ = Translcore.transl_module := transl_module @@ -376,22 +469,26 @@ let rec defined_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> defined_idents rem + | Tstr_eval (expr, _) -> defined_idents rem | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive(id, _, descr) -> defined_idents rem + | Tstr_primitive desc -> defined_idents rem | Tstr_type decls -> defined_idents rem - | Tstr_exception(id, _, decl) -> id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem - | Tstr_module(id, _, modl) -> id :: defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.ext_id :: defined_idents rem + | Tstr_module mb -> mb.mb_id :: defined_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem - | Tstr_modtype(id, _, decl) -> defined_idents rem + List.map (fun mb -> mb.mb_id) decls @ defined_idents rem + | Tstr_modtype _ -> defined_idents rem | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem + | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -399,44 +496,49 @@ let rec more_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> more_idents rem + | Tstr_eval (expr, _attrs) -> more_idents rem | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem - | Tstr_primitive(id, _, descr) -> more_idents rem + | Tstr_primitive _ -> more_idents rem | Tstr_type decls -> more_idents rem - | Tstr_exception(id, _, decl) -> more_idents rem - | Tstr_exn_rebind(id, _, path, _) -> more_idents rem + | Tstr_typext tyext -> more_idents rem + | Tstr_exception _ -> more_idents rem | Tstr_recmodule decls -> more_idents rem - | Tstr_modtype(id, _, decl) -> more_idents rem + | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, _) -> more_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - all_idents str.str_items @ more_idents rem - | Tstr_module(id, _, _) -> more_idents rem + | Tstr_include _ -> more_idents rem + | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} -> + all_idents str.str_items @ more_idents rem + | Tstr_module _ -> more_idents rem + | Tstr_attribute _ -> more_idents rem and all_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> all_idents rem + | Tstr_eval (expr, _attrs) -> all_idents rem | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem - | Tstr_primitive(id, _, descr) -> all_idents rem + | Tstr_primitive _ -> all_idents rem | Tstr_type decls -> all_idents rem - | Tstr_exception(id, _, decl) -> id :: all_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.ext_id :: all_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ all_idents rem - | Tstr_modtype(id, _, decl) -> all_idents rem + List.map (fun mb -> mb.mb_id) decls @ all_idents rem + | Tstr_modtype _ -> all_idents rem | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - id :: all_idents str.str_items @ all_idents rem - | Tstr_module(id, _, _) -> id :: all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem + | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} -> + mb_id :: all_idents str.str_items @ all_idents rem + | Tstr_module mb -> mb.mb_id :: all_idents rem + | Tstr_attribute _ -> all_idents rem (* A variant of transl_structure used to compile toplevel structure definitions @@ -466,7 +568,7 @@ let transl_store_structure glob map prims str = lambda_unit | item :: rem -> match item.str_desc with - | Tstr_eval expr -> + | Tstr_eval (expr, _attrs) -> Lsequence(subst_lambda subst (transl_exp expr), transl_store rootpath subst rem) | Tstr_value(rec_flag, pat_expr_list) -> @@ -474,20 +576,25 @@ let transl_store_structure glob map prims str = let lam = transl_let rec_flag pat_expr_list (store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_primitive(id, _, descr) -> + | Tstr_primitive descr -> record_primitive descr.val_val; transl_store rootpath subst rem | Tstr_type(decls) -> transl_store rootpath subst rem - | Tstr_exception( id, _, decl) -> - let lam = transl_exception id (field_path rootpath id) decl in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, _) -> - let lam = subst_lambda subst (transl_path path) in - Lsequence(Llet(Strict, id, lam, store_ident id), + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let lam = + transl_type_extension item.str_env rootpath tyext (store_idents ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let lam = transl_extension_constructor item.str_env path ext in + Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> + | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} -> let lam = transl_store (field_path rootpath id) subst str.str_items in (* Careful: see next case *) let subst = !transl_store_subst in @@ -500,9 +607,8 @@ let transl_store_structure glob map prims str = Lsequence(store_ident id, transl_store rootpath (add_ident true id subst) rem))) - | Tstr_module( id, _, modl) -> - let lam = - transl_module Tcoerce_none (field_path rootpath id) modl in + | Tstr_module{mb_id=id; mb_expr=modl} -> + let lam = transl_module Tcoerce_none (field_path rootpath id) modl in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. If so, keep using the local module value (id) in the remainder of @@ -513,7 +619,7 @@ let transl_store_structure glob map prims str = Lsequence(store_ident id, transl_store rootpath (add_ident true id subst) rem)) | Tstr_recmodule bindings -> - let ids = List.map fst4 bindings in + let ids = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule (fun id modl -> subst_lambda subst @@ -522,10 +628,6 @@ let transl_store_structure glob map prims str = bindings (Lsequence(store_idents ids, transl_store rootpath (add_idents true ids subst) rem)) - | Tstr_modtype(id, _, decl) -> - transl_store rootpath subst rem - | Tstr_open _ -> - transl_store rootpath subst rem | Tstr_class cl_list -> let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in let lam = @@ -538,10 +640,9 @@ let transl_store_structure glob map prims str = store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_class_type cl_list -> - transl_store rootpath subst rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem @@ -551,11 +652,16 @@ let transl_store_structure glob map prims str = Llet(Strict, mid, subst_lambda subst (transl_module Tcoerce_none None modl), store_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_store rootpath subst rem and store_ident id = try let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion cc (Lvar id) in + let init_val = apply_coercion Alias cc (Lvar id) in Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]) with Not_found -> fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) @@ -608,7 +714,8 @@ let build_ident_map restr idlist more_ids = match restr with Tcoerce_none -> natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) let idarray = Array.of_list idlist in let rec export_map pos map prims undef = function [] -> @@ -635,7 +742,7 @@ let transl_store_gen module_name ({ str_items = str }, restr) topl = let (map, prims, size) = build_ident_map restr (defined_idents str) (more_idents str) in let f = function - | [ { str_desc = Tstr_eval expr } ] when topl -> + | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> assert (size = 0); subst_lambda !transl_store_subst (transl_exp expr) | str -> transl_store_structure module_id map prims str in @@ -671,13 +778,13 @@ let toplevel_name id = let toploop_getvalue id = Lapply(Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id)))], + [Lconst(Const_base(Const_string (toplevel_name id, None)))], Location.none) let toploop_setvalue id lam = Lapply(Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id))); lam], + [Lconst(Const_base(Const_string (toplevel_name id, None))); lam], Location.none) let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -688,36 +795,33 @@ let close_toplevel_term lam = let transl_toplevel_item item = match item.str_desc with - Tstr_eval expr -> + Tstr_eval (expr, _attrs) -> transl_exp expr | Tstr_value(rec_flag, pat_expr_list) -> let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) - | Tstr_primitive(id, _, descr) -> - lambda_unit - | Tstr_type(decls) -> - lambda_unit - | Tstr_exception(id, _, decl) -> - toploop_setvalue id (transl_exception id None decl) - | Tstr_exn_rebind(id, _, path, _) -> - toploop_setvalue id (transl_path path) - | Tstr_module(id, _, modl) -> + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + toploop_setvalue ext.ext_id + (transl_extension_constructor item.str_env None ext) + | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) set_toplevel_unique_name id; - toploop_setvalue id - (transl_module Tcoerce_none (Some(Pident id)) modl) + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam | Tstr_recmodule bindings -> - let idents = List.map fst4 bindings in + let idents = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) - | Tstr_modtype(id, _, decl) -> - lambda_unit - | Tstr_open _ -> - lambda_unit | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) @@ -732,10 +836,9 @@ let transl_toplevel_item item = make_sequence (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) cl_list) - | Tstr_class_type cl_list -> - lambda_unit - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec set_idents pos = function [] -> @@ -744,6 +847,13 @@ let transl_toplevel_item item = Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), set_idents (pos + 1) ids) in Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_primitive _ + | Tstr_type _ + | Tstr_class_type _ + | Tstr_attribute _ -> + lambda_unit let transl_toplevel_item_and_close itm = close_toplevel_term (transl_label_init (transl_toplevel_item itm)) @@ -759,18 +869,24 @@ let get_component = function | Some id -> Lprim(Pgetglobal id, []) let transl_package component_names target_name coercion = + let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in + Lprim(Psetglobal target_name, [apply_coercion Strict coercion components]) + (* let components = match coercion with Tcoerce_none -> List.map get_component component_names - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let g = Array.of_list component_names in List.map - (fun (pos, cc) -> apply_coercion cc (get_component g.(pos))) + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) pos_cc_list | _ -> assert false in Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) let transl_store_package component_names target_name coercion = let rec make_sequence fn pos arg = @@ -786,15 +902,30 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); get_component id])) 0 component_names) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) + in + let blk = Ident.create "block" in + (List.length pos_cc_list, + Llet (Strict, blk, apply_coercion Strict coercion components, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal target_name, []); + Lprim(Pfield pos, [Lvar blk])])) + 0 pos_cc_list)) + (* + (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, make_sequence (fun dst (src, cc) -> Lprim(Psetfield(dst, false), [Lprim(Pgetglobal target_name, []); - apply_coercion cc (get_component id.(src))])) + apply_coercion Strict cc (get_component id.(src))])) 0 pos_cc_list) + *) | _ -> assert false (* Error report *) @@ -807,3 +938,18 @@ let report_error ppf = function "@[Cannot safely evaluate the definition@ \ of the recursively-defined module %a@]" Printtyp.ident id + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.empty; + toploop_ident.Ident.flags <- 0; + aliased_idents := Ident.empty diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 8e500554..1d84aaab 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -37,3 +37,5 @@ type error = exception Error of Location.t * error val report_error: Format.formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 97fdeb5d..02731ec6 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -20,7 +20,7 @@ open Lambda let oo_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) with Not_found -> fatal_error ("Primitive " ^ name ^ " not found.") @@ -86,19 +86,26 @@ let reset_labels () = (* Insert labels *) -let string s = Lconst (Const_base (Const_string s)) +let string s = Lconst (Const_base (Const_string (s, None))) let int n = Lconst (Const_base (Const_int n)) let prim_makearray = { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false } +(* Also use it for required globals *) let transl_label_init expr = let expr = Hashtbl.fold (fun c id expr -> Llet(Alias, id, Lconst c, expr)) consts expr in + let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals (); reset_labels (); expr @@ -155,3 +162,14 @@ let oo_wrap env req f x = wrapping := false; top_env := Env.empty; raise exn + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := IdentSet.empty diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 55c16343..a44ac683 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -26,3 +26,5 @@ val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index e9b7405f..c96e32b6 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args,_) -> args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,7 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args,_) -> args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/byterun/.depend b/byterun/.depend index 2f1780db..743737d0 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -7,7 +7,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -55,7 +55,7 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ @@ -66,7 +66,7 @@ interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -123,7 +123,7 @@ startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -147,7 +147,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -195,7 +195,7 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h @@ -208,7 +208,7 @@ interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -265,7 +265,7 @@ startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -289,7 +289,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -337,7 +337,7 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ @@ -348,7 +348,7 @@ interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -405,7 +405,7 @@ startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h diff --git a/byterun/Makefile b/byterun/Makefile index c5fa41bd..816dd75e 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -16,7 +16,7 @@ include Makefile.common CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR) -OBJS=$(COMMONOBJS) unix.o main.o +OBJS=$(COMMONOBJS) $(UNIX_OR_WIN32).o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o PICOBJS=$(OBJS:.o=.pic.o) @@ -46,7 +46,7 @@ libcamlrun_shared.so: $(PICOBJS) install:: if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi + cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so; fi clean:: rm -f libcamlrun_shared.so diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 35e66506..b6bff219 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -32,7 +32,8 @@ PRIMS=\ PUBLIC_INCLUDES=\ alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \ + version.h all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) @@ -48,15 +49,22 @@ ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf +# Installation + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + + install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + cp ocamlrun$(EXE) $(INSTALL_BINDIR)/ocamlrun$(EXE) + cp libcamlrun.$(A) $(INSTALL_LIBDIR)/libcamlrun.$(A) + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun.$(A) + if test -d $(INSTALL_LIBDIR)/caml; then : ; \ + else mkdir $(INSTALL_LIBDIR)/caml; fi for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + sed -f ../tools/cleanup-header $$i > $(INSTALL_LIBDIR)/caml/$$i; \ done - cp ld.conf $(LIBDIR)/ld.conf + cp ld.conf $(INSTALL_LIBDIR)/ld.conf .PHONY: install install:: install-$(RUNTIMED) @@ -65,8 +73,8 @@ install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) - cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) + cp ocamlrund$(EXE) $(INSTALL_BINDIR)/ocamlrund$(EXE) + cp libcamlrund.$(A) $(INSTALL_LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed # If primitives contain duplicated lines (e.g. because the code is defined @@ -110,8 +118,8 @@ jumptbl.h : instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ -e '/^}/q' instruct.h > jumptbl.h -version.h : ../VERSION - echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" > version.h +version.h : ../VERSION ../tools/make-version-header.sh + ../tools/make-version-header.sh ../VERSION > version.h clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) diff --git a/byterun/alloc.c b/byterun/alloc.c index a1fd2f03..1fc33b55 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -39,11 +39,13 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) }else if (wosize <= Max_young_wosize){ Alloc_small (result, wosize, tag); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = 0; + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; } }else{ result = caml_alloc_shr (wosize, tag); - if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); + if (tag < No_scan_tag){ + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + } result = caml_check_urgent_gc (result); } return result; diff --git a/byterun/alloc.h b/byterun/alloc.h index a0cd41b6..f00a7ef0 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -37,6 +37,7 @@ CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ CAMLextern value caml_alloc_array (value (*funct) (char const *), char const ** array); +CAMLextern value caml_alloc_sprintf(const char * format, ...); typedef void (*final_fun)(value); CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ diff --git a/byterun/array.c b/byterun/array.c index c9d991ed..ba6fd701 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -135,6 +135,27 @@ CAMLprim value caml_array_unsafe_set(value array, value index, value newval) return caml_array_unsafe_set_addr(array, index, newval); } +CAMLprim value caml_make_float_vect(value len) +{ + mlsize_t wosize = Long_val(len) * Double_wosize; + value result; + if (wosize == 0) + return Atom(0); + else if (wosize <= Max_young_wosize){ +#define Setup_for_gc +#define Restore_after_gc + Alloc_small (result, wosize, Double_array_tag); +#undef Setup_for_gc +#undef Restore_after_gc + }else if (wosize > Max_wosize) + caml_invalid_argument("Array.make_float"); + else { + result = caml_alloc_shr (wosize, Double_array_tag); + result = caml_check_urgent_gc (result); + } + return result; +} + CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -193,9 +214,13 @@ CAMLprim value caml_make_array(value init) || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { - Assert(size < Max_young_wosize); wsize = size * Double_wosize; - res = caml_alloc_small(wsize, Double_array_tag); + if (wsize <= Max_young_wosize) { + res = caml_alloc_small(wsize, Double_array_tag); + } else { + res = caml_alloc_shr(wsize, Double_array_tag); + res = caml_check_urgent_gc(res); + } for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 4098e47e..76e3ddf5 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -35,6 +35,7 @@ #include "stacks.h" #include "sys.h" #include "backtrace.h" +#include "fail.h" CAMLexport int caml_backtrace_active = 0; CAMLexport int caml_backtrace_pos = 0; @@ -93,15 +94,16 @@ CAMLprim value caml_backtrace_status(value vunit) /* Store the return addresses contained in the given stack fragment into the backtrace array */ -void caml_stash_backtrace(value exn, code_t pc, value * sp) +void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) { code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); if (pc != NULL) pc = pc - 1; - if (exn != caml_backtrace_last_exn) { + if (exn != caml_backtrace_last_exn || !reraise) { caml_backtrace_pos = 0; caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -119,6 +121,17 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } } +/* In order to prevent the GC from walking through the debug + information (which have no headers), we transform code pointers to + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as code pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Codet(p) Val_long((uintnat)p>>1) +#define Codet_Val(v) ((code_t)(Long_val(v)<<1)) + /* returns the next frame pointer (or NULL if none is available); updates *sp to point to the following one, and *trapsp to the next trap frame, which we will skip when we reach it */ @@ -165,7 +178,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { } } - trace = caml_alloc(trace_size, Abstract_tag); + trace = caml_alloc(trace_size, 0); /* then collect the trace */ { @@ -176,36 +189,52 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { code_t p = caml_next_frame_pointer(&sp, &trapsp); Assert(p != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) p) && Is_in_heap((value) p))); - Field(trace, trace_pos) = (value) p; + Field(trace, trace_pos) = Val_Codet(p); } } CAMLreturn(trace); } -/* Read the debugging info contained in the current bytecode executable. - Return an OCaml array of OCaml lists of debug_event records in "events", - or Val_false on failure. */ +/* Read the debugging info contained in the current bytecode executable. */ #ifndef O_BINARY #define O_BINARY 0 #endif +struct ev_info { + code_t ev_pc; + char * ev_filename; + int ev_lnum; + int ev_startchr; + int ev_endchr; +}; + +static int cmp_ev_info(const void *a, const void *b) { + code_t pc_a = ((const struct ev_info*)a)->ev_pc; + code_t pc_b = ((const struct ev_info*)b)->ev_pc; + if (pc_a > pc_b) return 1; + if (pc_a < pc_b) return -1; + return 0; +} + static char *read_debug_info_error = ""; -static value read_debug_info(void) +static uintnat n_events; +static struct ev_info *events = NULL; +static void read_debug_info(void) { CAMLparam0(); - CAMLlocal1(events); + CAMLlocal1(events_heap); char * exec_name; int fd; struct exec_trailer trail; struct channel * chan; uint32 num_events, orig, i; - value evl, l; + intnat j; + value evl, l, ev_start; + + if(events != NULL) + CAMLreturn0; if (caml_cds_file != NULL) { exec_name = caml_cds_file; @@ -215,54 +244,103 @@ static value read_debug_info(void) fd = caml_attempt_open(&exec_name, &trail, 1); if (fd < 0){ read_debug_info_error = "executable program file not found"; - CAMLreturn(Val_false); + CAMLreturn0; } caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); read_debug_info_error = "program not linked with -g"; - CAMLreturn(Val_false); + CAMLreturn0; } chan = caml_open_descriptor_in(fd); num_events = caml_getword(chan); - events = caml_alloc(num_events, 0); + n_events = 0; + events_heap = caml_alloc(num_events, 0); for (i = 0; i < num_events; i++) { orig = caml_getword(chan); evl = caml_input_val(chan); + caml_input_val(chan); // Skip the list of absolute directory names /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); + n_events++; } /* Record event list */ - Store_field(events, i, evl); + Store_field(events_heap, i, evl); } caml_close_channel(chan); - CAMLreturn(events); + + events = (struct ev_info*)malloc(n_events * sizeof(struct ev_info)); + if(events == NULL) { + read_debug_info_error = "out of memory"; + CAMLreturn0; + } + + j = 0; + for (i = 0; i < num_events; i++) { + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) { + uintnat fnsz; + value ev = Field(l, 0); + + events[j].ev_pc = + (code_t)((char*)caml_start_code + Long_val(Field(ev, EV_POS))); + + ev_start = Field (Field (ev, EV_LOC), LOC_START); + + fnsz = caml_string_length(Field (ev_start, POS_FNAME))+1; + events[j].ev_filename = (char*)malloc(fnsz); + if(events[j].ev_filename == NULL) { + for(j--; j >= 0; j--) + free(events[j].ev_filename); + free(events); + events = NULL; + read_debug_info_error = "out of memory"; + CAMLreturn0; + } + memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), + fnsz); + + events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM)); + events[j].ev_startchr = + Int_val (Field (ev_start, POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + events[j].ev_endchr = + Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + + j++; + } + } + + Assert(j == n_events); + + qsort(events, n_events, sizeof(struct ev_info), cmp_ev_info); + + CAMLreturn0; } -/* Search the event for the given PC. Return Val_false if not found. */ +/* Search the event index for the given PC. Return -1 if not found. */ -static value event_for_location(value events, code_t pc) +static intnat event_for_location(code_t pc) { - mlsize_t i; - value pos, l, ev, ev_pos, best_ev; - - best_ev = 0; + uintnat low = 0, high = n_events; Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); - pos = Val_long((char *) pc - (char *) caml_start_code); - for (i = 0; i < Wosize_val(events); i++) { - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { - ev = Field(l, 0); - ev_pos = Field(ev, EV_POS); - if (ev_pos == pos) return ev; - /* ocamlc sometimes moves an event past a following PUSH instruction; - allow mismatch by 1 instruction. */ - if (ev_pos == pos + 8) best_ev = ev; - } + Assert(events != NULL); + while(low+1 < high) { + uintnat m = (low+high)/2; + if(pc < events[m].ev_pc) high = m; + else low = m; } - if (best_ev != 0) return best_ev; - return Val_false; + if(events[low].ev_pc == pc) + return low; + /* ocamlc sometimes moves an event past a following PUSH instruction; + allow mismatch by 1 instruction. */ + if(events[low].ev_pc == pc + 1) + return low; + if(low+1 < n_events && events[low+1].ev_pc == pc + 1) + return low+1; + return -1; } /* Extract location information for the given PC */ @@ -276,27 +354,21 @@ struct loc_info { int loc_endchr; }; -static void extract_location_info(value events, code_t pc, +static void extract_location_info(code_t pc, /*out*/ struct loc_info * li) { - value ev, ev_start; - - ev = event_for_location(events, pc); - li->loc_is_raise = caml_is_instruction(*pc, RAISE); - if (ev == Val_false) { + intnat ev = event_for_location(pc); + li->loc_is_raise = caml_is_instruction(*pc, RAISE) || + caml_is_instruction(*pc, RERAISE); + if (ev == -1) { li->loc_valid = 0; return; } li->loc_valid = 1; - ev_start = Field (Field (ev, EV_LOC), LOC_START); - li->loc_filename = String_val (Field (ev_start, POS_FNAME)); - li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); - li->loc_startchr = - Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - li->loc_endchr = - Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); + li->loc_filename = events[ev].ev_filename; + li->loc_lnum = events[ev].ev_lnum; + li->loc_startchr = events[ev].ev_startchr; + li->loc_endchr = events[ev].ev_endchr; } /* Print location information -- same behavior as in Printexc */ @@ -333,55 +405,47 @@ static void print_location(struct loc_info * li, int index) CAMLexport void caml_print_exception_backtrace(void) { - value events; int i; struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { + read_debug_info(); + if (events == NULL) { fprintf(stderr, "(Cannot print stack backtrace: %s)\n", read_debug_info_error); return; } for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info(events, caml_backtrace_buffer[i], &li); + extract_location_info(caml_backtrace_buffer[i], &li); print_location(&li, i); } } /* Convert the backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) -{ - CAMLparam1(backtrace); - CAMLlocal5(events, res, arr, p, fname); - int i; +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { - res = Val_int(0); /* None */ + read_debug_info(); + if (events == NULL) + caml_failwith(read_debug_info_error); + + extract_location_info(Codet_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); } else { - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info(events, (code_t)Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); - } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - CAMLreturn(res); + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -390,20 +454,49 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer != NULL) { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) + Field(res, i) = Val_Codet(caml_backtrace_buffer[i]); + } CAMLreturn(res); } -/* the function below is deprecated: see asmrun/backtrace.c */ +/* the function below is deprecated: we previously returned directly + the OCaml-usable representation, instead of the raw backtrace as an + abstract type, but this has a large performance overhead if you + store a lot of backtraces and print only some of them. + + It is not used by the Printexc library anymore, or anywhere else in + the compiler, but we have kept it in case some user still depends + on it as an external. +*/ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw, res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal4(arr, raw_slot, slot, res); + + read_debug_info(); + if (events == NULL) { + res = Val_int(0); /* None */ + } else { + arr = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); + } else { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) { + raw_slot = Val_Codet(caml_backtrace_buffer[i]); + /* caml_convert_raw_backtrace_slot will not fail with + caml_failwith as we checked (events != NULL) already */ + slot = caml_convert_raw_backtrace_slot(raw_slot); + caml_modify(&Field(arr, i), slot); + } + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } CAMLreturn(res); } diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 158ca285..ec499919 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -24,7 +24,7 @@ CAMLextern char * caml_cds_file; CAMLprim value caml_record_backtrace(value vflag); #ifndef NATIVE_CODE -extern void caml_stash_backtrace(value exn, code_t pc, value * sp); +extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise); #endif CAMLextern void caml_print_exception_backtrace(void); diff --git a/byterun/callback.c b/byterun/callback.c index 3bd7ea45..5da37ec9 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -216,6 +216,7 @@ CAMLprim value caml_register_named_value(value vname, value val) { struct named_value * nv; char * name = String_val(vname); + size_t namelen = strlen(name); unsigned int h = hash_value_name(name); for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { @@ -225,8 +226,8 @@ CAMLprim value caml_register_named_value(value vname, value val) } } nv = (struct named_value *) - caml_stat_alloc(sizeof(struct named_value) + strlen(name)); - strcpy(nv->name, name); + caml_stat_alloc(sizeof(struct named_value) + namelen); + memcpy(nv->name, name, namelen + 1); nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; diff --git a/byterun/compact.c b/byterun/compact.c index bf803017..0afbd9dc 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -40,7 +40,7 @@ extern void caml_shrink_heap (char *); /* memory.c */ XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. - XXX (see [caml_register_global_roots] and [caml_init_exceptions]) + XXX (see [caml_register_global_roots]) XXX Should be able to fix it to only assume 2-byte alignment. */ #define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) diff --git a/byterun/compatibility.h b/byterun/compatibility.h index 58bf2834..11181176 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -112,7 +112,6 @@ #define raise_zero_divide caml_raise_zero_divide #define raise_not_found caml_raise_not_found #define raise_sys_blocked_io caml_raise_sys_blocked_io -#define init_exceptions caml_init_exceptions /* **** asmrun/fail.c */ /* **** asmrun/.s */ diff --git a/byterun/config.h b/byterun/config.h index 24f4e593..f7759885 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -25,30 +25,9 @@ #include "compatibility.h" #endif -/* Types for signed chars, 32-bit integers, 64-bit integers, +/* Types for 32-bit integers, 64-bit integers, native integers (as wide as a pointer type) */ -typedef signed char schar; - -#if SIZEOF_PTR == SIZEOF_LONG -/* Standard models: ILP32 or I32LP64 */ -typedef long intnat; -typedef unsigned long uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "l" -#elif SIZEOF_PTR == SIZEOF_INT -/* Hypothetical IP32L64 model */ -typedef int intnat; -typedef unsigned int uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "" -#elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE) -/* Win64 model: IL32LLP64 */ -typedef ARCH_INT64_TYPE intnat; -typedef ARCH_UINT64_TYPE uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT -#else -#error "No integer type available to represent pointers" -#endif - #if SIZEOF_INT == 4 typedef int int32; typedef unsigned int uint32; @@ -65,15 +44,40 @@ typedef unsigned short uint32; #error "No 32-bit integer type available" #endif -#if defined(ARCH_INT64_TYPE) +#ifndef ARCH_INT64_TYPE +#if SIZEOF_LONGLONG == 8 +#define ARCH_INT64_TYPE long long +#define ARCH_UINT64_TYPE unsigned long long +#define ARCH_INT64_PRINTF_FORMAT "ll" +#elif SIZEOF_LONG == 8 +#define ARCH_INT64_TYPE long +#define ARCH_UINT64_TYPE unsigned long +#define ARCH_INT64_PRINTF_FORMAT "l" +#else +#error "No 64-bit integer type available" +#endif +#endif + typedef ARCH_INT64_TYPE int64; typedef ARCH_UINT64_TYPE uint64; + +#if SIZEOF_PTR == SIZEOF_LONG +/* Standard models: ILP32 or I32LP64 */ +typedef long intnat; +typedef unsigned long uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "l" +#elif SIZEOF_PTR == SIZEOF_INT +/* Hypothetical IP32L64 model */ +typedef int intnat; +typedef unsigned int uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "" +#elif SIZEOF_PTR == 8 +/* Win64 model: IL32LLP64 */ +typedef int64 intnat; +typedef uint64 uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT #else -# ifdef ARCH_BIG_ENDIAN -typedef struct { uint32 h, l; } uint64, int64; -# else -typedef struct { uint32 l, h; } uint64, int64; -# endif +#error "No integer type available to represent pointers" #endif /* Endianness of floats */ @@ -139,16 +143,17 @@ typedef struct { uint32 l, h; } uint64, int64; /* Minimum size increment when growing the heap (words). Must be a multiple of [Page_size / sizeof (value)]. */ -#define Heap_chunk_min (2 * Page_size / sizeof (value)) +#define Heap_chunk_min (15 * Page_size) -/* Default size increment when growing the heap. (words) - Must be a multiple of [Page_size / sizeof (value)]. - (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ -#define Heap_chunk_def (31 * Page_size) +/* Default size increment when growing the heap. + If this is <= 1000, it's a percentage of the current heap size. + If it is > 1000, it's a number of words. */ +#define Heap_chunk_def 15 /* Default initial size of the major heap (words); - same constraints as for Heap_chunk_def. */ + Must be a multiple of [Page_size / sizeof (value)]. */ #define Init_heap_def (31 * Page_size) +/* (about 512 kB for a 32-bit platform, 1 MB for a 64-bit platform.) */ /* Default speed setting for the major GC. The heap will grow until diff --git a/byterun/debugger.c b/byterun/debugger.c index d64583f2..6024ed92 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -250,7 +250,6 @@ static void safe_output_value(struct channel *chan, value val) void caml_debugger(enum event_kind event) { - int frame_number; value * frame; intnat i, pos; value val; @@ -258,7 +257,6 @@ void caml_debugger(enum event_kind event) if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ - frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index f07cf91e..8b4498b9 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -79,9 +79,7 @@ static char * parse_ld_conf(void) stdlib = getenv("OCAMLLIB"); if (stdlib == NULL) stdlib = getenv("CAMLLIB"); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; - ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); - strcpy(ldconfname, stdlib); - strcat(ldconfname, "/" LD_CONF_NAME); + ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME); if (stat(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; diff --git a/byterun/exec.h b/byterun/exec.h index 8b50484d..a58bcf8b 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -54,7 +54,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X008" +#define EXEC_MAGIC "Caml1999X011" #endif /* CAML_EXEC_H */ diff --git a/byterun/fail.c b/byterun/fail.c index d721d5c9..148e47a9 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -39,13 +39,7 @@ CAMLexport void caml_raise(value v) CAMLexport void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } CAMLexport void caml_raise_with_arg(value tag, value arg) @@ -77,11 +71,9 @@ CAMLexport void caml_raise_with_args(value tag, int nargs, value args[]) CAMLexport void caml_raise_with_string(value tag, char const *msg) { - CAMLparam1 (tag); - CAMLlocal1 (vmsg); - - vmsg = caml_copy_string(msg); - caml_raise_with_arg(tag, vmsg); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); CAMLnoreturn; } @@ -111,21 +103,9 @@ CAMLexport void caml_array_bound_error(void) caml_invalid_argument("index out of bounds"); } -/* Problem: we can't use [caml_raise_constant], because it allocates and - we're out of memory... Here, we allocate statically the exn bucket - for [Out_of_memory]. */ - -static struct { - header_t hdr; - value exn; -} out_of_memory_bucket = { 0, 0 }; - CAMLexport void caml_raise_out_of_memory(void) { - if (out_of_memory_bucket.exn == 0) - caml_fatal_error - ("Fatal error: out of memory while raising Out_of_memory\n"); - caml_raise((value) &(out_of_memory_bucket.exn)); + caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN)); } CAMLexport void caml_raise_stack_overflow(void) @@ -158,15 +138,6 @@ CAMLexport void caml_raise_sys_blocked_io(void) caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } -/* Initialization of statically-allocated exception buckets */ - -void caml_init_exceptions(void) -{ - out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); - out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); - caml_register_global_root(&out_of_memory_bucket.exn); -} - int caml_is_special_exception(value exn) { return exn == Field(caml_global_data, MATCH_FAILURE_EXN) || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) diff --git a/byterun/fail.h b/byterun/fail.h index 68322741..da72c780 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -74,7 +74,6 @@ CAMLextern void caml_raise_sys_error (value) Noreturn; CAMLextern void caml_raise_end_of_file (void) Noreturn; CAMLextern void caml_raise_zero_divide (void) Noreturn; CAMLextern void caml_raise_not_found (void) Noreturn; -CAMLextern void caml_init_exceptions (void); CAMLextern void caml_array_bound_error (void) Noreturn; CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 746f8b75..3380dc91 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -98,10 +98,10 @@ char * caml_instr_base; void caml_thread_code (code_t code, asize_t len) { code_t p; - int l [STOP + 1]; + int l [FIRST_UNIMPLEMENTED_OP]; int i; - for (i = 0; i <= STOP; i++) { + for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { l [i] = 0; } /* Instructions with one operand */ @@ -125,7 +125,7 @@ void caml_thread_code (code_t code, asize_t len) len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; - if (instr < 0 || instr > STOP){ + if (instr < 0 || instr >= FIRST_UNIMPLEMENTED_OP){ /* FIXME -- should Assert(false) ? caml_fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); diff --git a/byterun/floats.c b/byterun/floats.c index 9071106f..7ff6d89d 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -71,68 +71,29 @@ CAMLexport value caml_copy_double(double d) CAMLprim value caml_format_float(value fmt, value arg) { -#define MAX_DIGITS 350 -/* Max number of decimal digits in a "natural" (not artificially padded) - representation of a float. Can be quite big for %f format. - Max exponent for IEEE format is 308 decimal digits. - Rounded up for good measure. */ - char format_buffer[MAX_DIGITS + 20]; - int prec, i; - char * p; - char * dest; value res; double d = Double_val(arg); #ifdef HAS_BROKEN_PRINTF if (isfinite(d)) { #endif - prec = MAX_DIGITS; - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - i = atoi(p) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - for( ; *p != 0; p++) { - if (*p == '.') { - i = atoi(p+1) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - if (prec < sizeof(format_buffer)) { - dest = format_buffer; - } else { - dest = caml_stat_alloc(prec); - } - sprintf(dest, String_val(fmt), d); - res = caml_copy_string(dest); - if (dest != format_buffer) { - caml_stat_free(dest); - } + res = caml_alloc_sprintf(String_val(fmt), d); #ifdef HAS_BROKEN_PRINTF } else { - if (isnan(d)) - { + if (isnan(d)) { res = caml_copy_string("nan"); - } - else - { + } else { if (d > 0) - { res = caml_copy_string("inf"); - } else - { res = caml_copy_string("-inf"); - } } } #endif return res; } +#if 0 /*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) { char parse_buffer[64]; @@ -163,6 +124,7 @@ CAMLprim value caml_format_float(value fmt, value arg) if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); } +#endif CAMLprim value caml_float_of_string(value vs) { diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 84327fa2..7e61f0c1 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -43,10 +43,10 @@ intnat caml_stat_minor_collections = 0, caml_stat_compactions = 0, caml_stat_heap_chunks = 0; -extern uintnat caml_major_heap_increment; /* bytes; see major_gc.c */ -extern uintnat caml_percent_free; /* see major_gc.c */ -extern uintnat caml_percent_max; /* see compact.c */ -extern uintnat caml_allocation_policy; /* see freelist.c */ +extern uintnat caml_major_heap_increment; /* percent or words; see major_gc.c */ +extern uintnat caml_percent_free; /* see major_gc.c */ +extern uintnat caml_percent_max; /* see compact.c */ +extern uintnat caml_allocation_policy; /* see freelist.c */ #define Next(hp) ((hp) + Bhsize_hp (hp)) @@ -346,14 +346,6 @@ static uintnat norm_pmax (uintnat p) return p; } -static intnat norm_heapincr (uintnat i) -{ -#define Psv (Wsize_bsize (Page_size)) - i = ((i + Psv - 1) / Psv) * Psv; - if (i < Heap_chunk_min) i = Heap_chunk_min; - return i; -} - static intnat norm_minsize (intnat s) { if (s < Minor_heap_min) s = Minor_heap_min; @@ -386,11 +378,16 @@ CAMLprim value caml_gc_set(value v) caml_gc_message (0x20, "New max overhead: %d%%\n", caml_percent_max); } - newheapincr = Bsize_wsize (norm_heapincr (Long_val (Field (v, 1)))); + newheapincr = Long_val (Field (v, 1)); if (newheapincr != caml_major_heap_increment){ caml_major_heap_increment = newheapincr; - caml_gc_message (0x20, "New heap increment size: %luk bytes\n", - caml_major_heap_increment/1024); + if (newheapincr > 1000){ + caml_gc_message (0x20, "New heap increment size: %luk words\n", + caml_major_heap_increment/1024); + }else{ + caml_gc_message (0x20, "New heap increment size: %lu%%\n", + caml_major_heap_increment); + } } oldpolicy = caml_allocation_policy; caml_set_allocation_policy (Long_val (Field (v, 6))); @@ -475,17 +472,26 @@ CAMLprim value caml_gc_compaction(value v) return Val_unit; } +uintnat caml_normalize_heap_increment (uintnat i) +{ + if (i < Bsize_wsize (Heap_chunk_min)){ + i = Bsize_wsize (Heap_chunk_min); + } + return ((i + Page_size - 1) >> Page_log) << Page_log; +} + void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, uintnat percent_m) { - uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); + uintnat major_heap_size = + Bsize_wsize (caml_normalize_heap_increment (major_size)); if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){ caml_fatal_error ("OCaml runtime error: cannot initialize page table\n"); } caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); - caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + caml_major_heap_increment = major_incr; caml_percent_free = norm_pfree (percent_fr); caml_percent_max = norm_pmax (percent_m); caml_init_major_heap (major_heap_size); @@ -495,8 +501,13 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, major_heap_size / 1024); caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); - caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", - caml_major_heap_increment / 1024); + if (caml_major_heap_increment > 1000){ + caml_gc_message (0x20, "Initial heap increment: %luk words\n", + caml_major_heap_increment / 1024); + }else{ + caml_gc_message (0x20, "Initial heap increment: %lu%%\n", + caml_major_heap_increment); + } caml_gc_message (0x20, "Initial allocation policy: %d\n", caml_allocation_policy); } diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h index 5f9d8735..de6933e8 100644 --- a/byterun/gc_ctrl.h +++ b/byterun/gc_ctrl.h @@ -29,6 +29,8 @@ extern intnat caml_stat_compactions, caml_stat_heap_chunks; +uintnat caml_normalize_heap_increment (uintnat); + void caml_init_gc (uintnat, uintnat, uintnat, uintnat, uintnat); diff --git a/byterun/hash.c b/byterun/hash.c index 61bee20c..f8964265 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -21,12 +21,6 @@ #include "memory.h" #include "hash.h" -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ @@ -77,9 +71,7 @@ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) { - uint32 hi, lo; - - I64_split(d, hi, lo); + uint32 hi = (uint32) (d >> 32), lo = (uint32) d; MIX(h, lo); MIX(h, hi); return h; @@ -180,6 +172,8 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) /* Maximal size of the queue used for breadth-first traversal. */ #define HASH_QUEUE_SIZE 256 +/* Maximal number of Forward_tag links followed in one step */ +#define MAX_FORWARD_DEREFERENCE 1000 /* The generic hash function */ @@ -221,7 +215,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; - if (num < 0) break; + if (num <= 0) break; } break; case Abstract_tag: @@ -234,8 +228,15 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) v = v - Infix_offset_val(v); goto again; case Forward_tag: - v = Forward_val(v); - goto again; + /* PR#6361: we can have a loop here, so limit the number of + Forward_tag links being followed */ + for (i = MAX_FORWARD_DEREFERENCE; i > 0; i--) { + v = Forward_val(v); + if (Is_long(v) || !Is_in_value_area(v) || Tag_val(v) != Forward_tag) + goto again; + } + /* Give up on this object and move to the next */ + break; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); num--; diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 2934984d..0a19fd2f 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -84,7 +84,7 @@ char * caml_instr_string (code_t pc) char *nam; nam = (instr < 0 || instr > STOP) - ? (sprintf (nambuf, "???%d", instr), nambuf) + ? (snprintf (nambuf, sizeof(nambuf), "???%d", instr), nambuf) : names_of_instructions[instr]; pc++; switch (instr) { @@ -125,7 +125,7 @@ char * caml_instr_string (code_t pc) case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: - sprintf(buf, "%s %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d", nam, pc[0]); break; /* Instructions with two operands */ case APPTERM: @@ -142,16 +142,16 @@ char * caml_instr_string (code_t pc) case BGEINT: case BULTINT: case BUGEINT: - sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]); + snprintf(buf, sizeof(buf), "%s %d, %d", nam, pc[0], pc[1]); break; case SWITCH: - sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld", + snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%ld nint%ld", (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, (unsigned long) pc[0] & 0xffff); break; /* Instructions with a C primitive as operand */ case C_CALLN: - sprintf(buf, "%s %d,", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d,", nam, pc[0]); pc++; /* fallthrough */ case C_CALL1: @@ -160,12 +160,13 @@ char * caml_instr_string (code_t pc) case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) - sprintf(buf, "%s unknown primitive %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s unknown primitive %d", nam, pc[0]); else - sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); + snprintf(buf, sizeof(buf), "%s %s", + nam, (char *) caml_prim_name_table.contents[pc[0]]); break; default: - sprintf(buf, "%s", nam); + snprintf(buf, sizeof(buf), "%s", nam); break; }; return buf; diff --git a/byterun/instruct.h b/byterun/instruct.h index 56860500..f9cc80ee 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -39,7 +39,8 @@ enum instructions { VECTLENGTH, GETVECTITEM, SETVECTITEM, GETSTRINGCHAR, SETSTRINGCHAR, BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, - PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, + PUSHTRAP, POPTRAP, RAISE, + CHECK_SIGNALS, C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, @@ -53,7 +54,9 @@ enum instructions { BULTINT, BUGEINT, GETPUBMET, GETDYNMET, STOP, - EVENT, BREAK -}; + EVENT, BREAK, + RERAISE, RAISE_NOTRACE, +FIRST_UNIMPLEMENTED_OP}; + #endif /* CAML_INSTRUCT_H */ diff --git a/byterun/intern.c b/byterun/intern.c index bfe18b1a..e0fcc5db 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -64,10 +64,6 @@ static value intern_block; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ -static value * camlinternaloo_last_id = NULL; -/* Pointer to a reference holding the last object id. - -1 means not available (CamlinternalOO not loaded). */ - static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset); static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; @@ -290,16 +286,9 @@ static void intern_rec(value *dest) switch (sp->op) { case OFreshOID: /* Refresh the object ID */ - if (camlinternaloo_last_id == NULL) { - camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); - if (camlinternaloo_last_id == NULL) - camlinternaloo_last_id = (value*) (-1); - } - if (camlinternaloo_last_id != (value*) (-1)) { - value id = Field(*camlinternaloo_last_id,0); - Field(dest, 0) = id; - Field(*camlinternaloo_last_id,0) = id + 2; - } + /* but do not do it for predefined exception slots */ + if (Int_val(Field((value)dest, 1)) >= 0) + caml_set_oo_id((value)dest); /* Pop item and iterate */ sp--; break; @@ -336,7 +325,7 @@ static void intern_rec(value *dest) /* Request freshing OID */ PushItem(); sp->op = OFreshOID; - sp->dest = &Field(v, 1); + sp->dest = (value*) v; sp->arg = 1; /* Finally read first two block elements: method table and old OID */ ReadItems(&Field(v, 0), 2); @@ -503,8 +492,6 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) { mlsize_t wosize; - if (camlinternaloo_last_id == (value*)-1) - camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; @@ -751,7 +738,8 @@ static char * intern_resolve_code_pointer(unsigned char digest[16], static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - sprintf(msg, "input_value: unknown code module " + snprintf(msg, sizeof(msg), + "input_value: unknown code module " "%02X%02X%02X%02X%02X%02X%02X%02X" "%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], diff --git a/byterun/interp.c b/byterun/interp.c index b99ed2f8..9b682ba6 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -173,16 +173,14 @@ sp is a local copy of the global variable caml_extern_sp. */ #define SP_REG asm("%r14") #define ACCU_REG asm("%r13") #endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") #endif - -/* Division and modulus madness */ - -#ifdef NONSTANDARD_DIV_MOD -extern intnat caml_safe_div(intnat p, intnat q); -extern intnat caml_safe_mod(intnat p, intnat q); #endif - #ifdef DEBUG static intnat caml_bcodcount; #endif @@ -525,10 +523,21 @@ value caml_interprete(code_t prog, asize_t prog_size) int nvars = *pc++; int i; if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); + if (nvars < Max_young_wosize) { + /* nvars + 1 <= Max_young_wosize, can allocate in minor heap */ + Alloc_small(accu, 1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) caml_initialize(&Field(accu, i + 1), sp[i]); + } + /* The code pointer is not in the heap, so no need to go through + caml_initialize. */ Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } @@ -536,15 +545,25 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(CLOSUREREC): { int nfuncs = *pc++; int nvars = *pc++; + mlsize_t blksize = nfuncs * 2 - 1 + nvars; int i; value * p; if (nvars > 0) *--sp = accu; - Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = sp[i]; + if (blksize <= Max_young_wosize) { + Alloc_small(accu, blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) *p = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) caml_initialize(p, sp[i]); } sp += nvars; + /* The code pointers and infix headers are not in the heap, + so no need to go through caml_initialize. */ p = &Field(accu, 0); *p = (value) (pc + pc[0]); *--sp = accu; @@ -814,10 +833,20 @@ value caml_interprete(code_t prog, asize_t prog_size) sp += 4; Next; + Instruct(RAISE_NOTRACE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + goto raise_notrace; + + Instruct(RERAISE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1); + goto raise_notrace; + Instruct(RAISE): raise_exception: if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); - if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0); + raise_notrace: if ((char *) caml_trapsp >= (char *) caml_stack_high - initial_sp_offset) { caml_external_raise = initial_external_raise; @@ -946,21 +975,13 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(DIVINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_div(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) / divisor); -#endif Next; } Instruct(MODINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) % divisor); -#endif Next; } Instruct(ANDINT): diff --git a/byterun/ints.c b/byterun/ints.c index 4bf1d332..d762c761 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -96,24 +96,6 @@ static intnat parse_intnat(value s, int nbits) return sign < 0 ? -((intnat) res) : (intnat) res; } -#ifdef NONSTANDARD_DIV_MOD -intnat caml_safe_div(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap / aq; - return (p ^ q) >= 0 ? ar : -ar; -} - -intnat caml_safe_mod(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap % aq; - return p >= 0 ? ar : -ar; -} -#endif - value caml_bswap16_direct(value x) { return ((((x & 0x00FF) << 8) | @@ -142,13 +124,10 @@ CAMLprim value caml_int_of_string(value s) #define FORMAT_BUFFER_SIZE 32 -static char * parse_format(value fmt, - char * suffix, - char format_string[], - char default_format_buffer[], - char *conv) +static char parse_format(value fmt, + char * suffix, + char format_string[FORMAT_BUFFER_SIZE]) { - int prec; char * p; char lastletter; mlsize_t len, len_suffix; @@ -167,41 +146,25 @@ static char * parse_format(value fmt, memmove(p, suffix, len_suffix); p += len_suffix; *p++ = lastletter; *p = 0; - /* Determine space needed for result and allocate it dynamically if needed */ - prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - prec = atoi(p) + 5; - break; - } - } - *conv = lastletter; - if (prec < FORMAT_BUFFER_SIZE) - return default_format_buffer; - else - return caml_stat_alloc(prec + 1); + /* Return the conversion type (last letter) */ + return lastletter; } CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; char conv; value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); + conv = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); switch (conv) { case 'u': case 'x': case 'X': case 'o': - sprintf(buffer, format_string, Unsigned_long_val(arg)); + res = caml_alloc_sprintf(format_string, Unsigned_long_val(arg)); break; default: - sprintf(buffer, format_string, Long_val(arg)); + res = caml_alloc_sprintf(format_string, Long_val(arg)); break; } - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } @@ -269,11 +232,7 @@ CAMLprim value caml_int32_div(value v1, value v2) /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_div(dividend, divisor)); -#else return caml_copy_int32(dividend / divisor); -#endif } CAMLprim value caml_int32_mod(value v1, value v2) @@ -284,11 +243,7 @@ CAMLprim value caml_int32_mod(value v1, value v2) /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_mod(dividend, divisor)); -#else return caml_copy_int32(dividend % divisor); -#endif } CAMLprim value caml_int32_and(value v1, value v2) @@ -346,17 +301,9 @@ CAMLprim value caml_int32_compare(value v1, value v2) CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Int32_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int32_val(arg)); } CAMLprim value caml_int32_of_string(value s) @@ -380,12 +327,6 @@ CAMLprim value caml_int32_float_of_bits(value vi) /* 64-bit integers */ -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - #ifdef ARCH_ALIGN_INT64 CAMLexport int64 caml_Int64_val(value v) @@ -402,15 +343,13 @@ static int int64_cmp(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); - return I64_compare(i1, i2); + return (i1 > i2) - (i1 < i2); } static intnat int64_hash(value v) { int64 x = Int64_val(v); - uint32 lo, hi; - - I64_split(x, hi, lo); + uint32 lo = (uint32) x, hi = (uint32) (x >> 32); return hi ^ lo; } @@ -459,59 +398,58 @@ CAMLexport value caml_copy_int64(int64 i) } CAMLprim value caml_int64_neg(value v) -{ return caml_copy_int64(I64_neg(Int64_val(v))); } +{ return caml_copy_int64(- Int64_val(v)); } CAMLprim value caml_int64_add(value v1, value v2) -{ return caml_copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) + Int64_val(v2)); } CAMLprim value caml_int64_sub(value v1, value v2) -{ return caml_copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) - Int64_val(v2)); } CAMLprim value caml_int64_mul(value v1, value v2) -{ return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) * Int64_val(v2)); } + +#define Int64_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) CAMLprim value caml_int64_div(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; - return caml_copy_int64(I64_div(Int64_val(v1), divisor)); + if (dividend == ((int64)1 << 63) && divisor == -1) return v1; + return caml_copy_int64(Int64_val(v1) / divisor); } CAMLprim value caml_int64_mod(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { - int64 zero = I64_literal(0,0); - return caml_copy_int64(zero); - } - return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); + if (dividend == ((int64)1 << 63) && divisor == -1) return caml_copy_int64(0); + return caml_copy_int64(Int64_val(v1) % divisor); } CAMLprim value caml_int64_and(value v1, value v2) -{ return caml_copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) & Int64_val(v2)); } CAMLprim value caml_int64_or(value v1, value v2) -{ return caml_copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) | Int64_val(v2)); } CAMLprim value caml_int64_xor(value v1, value v2) -{ return caml_copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) ^ Int64_val(v2)); } CAMLprim value caml_int64_shift_left(value v1, value v2) -{ return caml_copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) << Int_val(v2)); } CAMLprim value caml_int64_shift_right(value v1, value v2) -{ return caml_copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64((uint64) (Int64_val(v1)) >> Int_val(v2)); } #ifdef ARCH_SIXTYFOUR static value caml_swap64(value x) @@ -531,98 +469,92 @@ value caml_int64_direct_bswap(value v) #endif CAMLprim value caml_int64_bswap(value v) -{ return caml_copy_int64(I64_bswap(Int64_val(v))); } +{ + int64 x = Int64_val(v); + return caml_copy_int64 + (((x & 0x00000000000000FFULL) << 56) | + ((x & 0x000000000000FF00ULL) << 40) | + ((x & 0x0000000000FF0000ULL) << 24) | + ((x & 0x00000000FF000000ULL) << 8) | + ((x & 0x000000FF00000000ULL) >> 8) | + ((x & 0x0000FF0000000000ULL) >> 24) | + ((x & 0x00FF000000000000ULL) >> 40) | + ((x & 0xFF00000000000000ULL) >> 56)); +} CAMLprim value caml_int64_of_int(value v) -{ return caml_copy_int64(I64_of_intnat(Long_val(v))); } +{ return caml_copy_int64((int64) (Long_val(v))); } CAMLprim value caml_int64_to_int(value v) -{ return Val_long(I64_to_intnat(Int64_val(v))); } +{ return Val_long((intnat) (Int64_val(v))); } CAMLprim value caml_int64_of_float(value v) -{ return caml_copy_int64(I64_of_double(Double_val(v))); } +{ return caml_copy_int64((int64) (Double_val(v))); } CAMLprim value caml_int64_to_float(value v) -{ - int64 i = Int64_val(v); - return caml_copy_double(I64_to_double(i)); -} +{ return caml_copy_double((double) (Int64_val(v))); } CAMLprim value caml_int64_of_int32(value v) -{ return caml_copy_int64(I64_of_int32(Int32_val(v))); } +{ return caml_copy_int64((int64) (Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) -{ return caml_copy_int32(I64_to_int32(Int64_val(v))); } +{ return caml_copy_int32((int32) (Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) -{ return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); } +{ return caml_copy_int64((int64) (Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) -{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); } +{ return caml_copy_nativeint((intnat) (Int64_val(v))); } CAMLprim value caml_int64_compare(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); - return Val_int(I64_compare(i1, i2)); + return Val_int((i1 > i2) - (i1 < i2)); } -#ifdef ARCH_INT64_PRINTF_FORMAT -#define I64_format(buf,fmt,x) sprintf(buf,fmt,x) -#else -#include "int64_format.h" -#define ARCH_INT64_PRINTF_FORMAT "" -#endif - CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - I64_format(buffer, format_string, Int64_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int64_val(arg)); } CAMLprim value caml_int64_of_string(value s) { char * p; - uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); - uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF); - uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000); uint64 res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); - I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); + threshold = ((uint64) -1) / base; d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); - res = I64_of_int32(d); + res = d; for (p++; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (I64_ult(threshold, res)) caml_failwith("int_of_string"); - res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + if (res > threshold) caml_failwith("int_of_string"); + res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); + if (res < (uint64) d) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); } if (base == 10) { - if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res)) - caml_failwith("int_of_string"); + /* Signed representation expected, allow -2^63 to 2^63 - 1 only */ + if (sign >= 0) { + if (res >= (uint64)1 << 63) caml_failwith("int_of_string"); + } else { + if (res > (uint64)1 << 63) caml_failwith("int_of_string"); + } } - if (sign < 0) res = I64_neg(res); + if (sign < 0) res = - res; return caml_copy_int64(res); } @@ -745,11 +677,7 @@ CAMLprim value caml_nativeint_div(value v1, value v2) /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_div(dividend, divisor)); -#else return caml_copy_nativeint(dividend / divisor); -#endif } CAMLprim value caml_nativeint_mod(value v1, value v2) @@ -762,11 +690,7 @@ CAMLprim value caml_nativeint_mod(value v1, value v2) if (dividend == Nativeint_min_int && divisor == -1){ return caml_copy_nativeint(0); } -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); -#else return caml_copy_nativeint(dividend % divisor); -#endif } CAMLprim value caml_nativeint_and(value v1, value v2) @@ -834,17 +758,9 @@ CAMLprim value caml_nativeint_compare(value v1, value v2) CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Nativeint_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Nativeint_val(arg)); } CAMLprim value caml_nativeint_of_string(value s) diff --git a/byterun/io.c b/byterun/io.c index 676cb5b2..5f04a966 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -22,6 +22,9 @@ #ifdef HAS_UNISTD #include #endif +#ifdef __CYGWIN__ +#include +#endif #include "alloc.h" #include "custom.h" #include "fail.h" @@ -788,21 +791,3 @@ CAMLprim value caml_ml_input_scan_line(value vchannel) Unlock(channel); CAMLreturn (Val_long(res)); } - -/* Conversion between file_offset and int64 */ - -#ifndef ARCH_INT64_TYPE -CAMLexport value caml_Val_file_offset(file_offset fofs) -{ - int64 ofs; - ofs.l = fofs; - ofs.h = 0; - return caml_copy_int64(ofs); -} - -CAMLexport file_offset caml_File_offset_val(value v) -{ - int64 ofs = Int64_val(v); - return (file_offset) ofs.l; -} -#endif diff --git a/byterun/io.h b/byterun/io.h index 8420d159..64a8bf50 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -25,8 +25,6 @@ #if defined(_WIN32) typedef __int64 file_offset; -extern __int64 _lseeki64(int, __int64, int); -#define lseek(fd,d,m) _lseeki64(fd,d,m) #elif defined(HAS_OFF_T) #include typedef off_t file_offset; @@ -111,14 +109,7 @@ CAMLextern struct channel * caml_all_opened_channels; /* Conversion between file_offset and int64 */ -#ifdef ARCH_INT64_TYPE #define Val_file_offset(fofs) caml_copy_int64(fofs) #define File_offset_val(v) ((file_offset) Int64_val(v)) -#else -CAMLextern value caml_Val_file_offset(file_offset fofs); -CAMLextern file_offset caml_File_offset_val(value v); -#define Val_file_offset caml_Val_file_offset -#define File_offset_val caml_File_offset_val -#endif #endif /* CAML_IO_H */ diff --git a/byterun/lexing.c b/byterun/lexing.c index 8242cc7a..22ef6acd 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -49,7 +49,7 @@ struct lexing_table { #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 14a248f0..a44c8d90 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -27,6 +27,12 @@ #include "roots.h" #include "weak.h" +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +#define NATIVE_CODE_AND_NO_NAKED_POINTERS +#else +#undef NATIVE_CODE_AND_NO_NAKED_POINTERS +#endif + uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; @@ -82,7 +88,18 @@ static void realloc_gray_vals (void) void caml_darken (value v, value *p /* not used */) { +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (v) && Wosize_val (v) > 0) { + /* We insist that naked pointers to outside the heap point to things that + look like values with headers coloured black. This isn't always + strictly necessary but is essential in certain cases---in particular + when the value is allocated in a read-only section. (For the values + where it would be safe it is a performance improvement since we avoid + putting them on the grey list.) */ + CAMLassert (Is_in_heap (v) || Is_black_hd (Hd_val (v))); +#else if (Is_block (v) && Is_in_heap (v)) { +#endif header_t h = Hd_val (v); tag_t t = Tag_hd (h); if (t == Infix_tag){ @@ -124,6 +141,9 @@ static void mark_slice (intnat work) value v, child; header_t hd; mlsize_t size, i; +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + int marking_closure = 0; +#endif caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); @@ -132,13 +152,28 @@ static void mark_slice (intnat work) if (gray_vals_ptr > gray_vals){ v = *--gray_vals_ptr; hd = Hd_val(v); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + marking_closure = + (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag); +#endif Assert (Is_gray_hd (hd)); Hd_val (v) = Blackhd_hd (hd); size = Wosize_hd (hd); if (Tag_hd (hd) < No_scan_tag){ for (i = 0; i < size; i++){ child = Field (v, i); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (child) + && Wosize_val (child) > 0 /* Atoms never need to be marked. */ + /* Closure blocks contain code pointers at offsets that cannot + be reliably determined, so we always use the page table when + marking such values. */ + && (!marking_closure || Is_in_heap (child))) { + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (Hd_val (child))); +#else if (Is_block (child) && Is_in_heap (child)) { +#endif hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); @@ -457,15 +492,23 @@ static asize_t clip_heap_chunk_size (asize_t request) return ((request + Page_size - 1) >> Page_log) << Page_log; } -/* Make sure the request is >= caml_major_heap_increment, then call - clip_heap_chunk_size, then make sure the result is >= request. +/* Compute the heap increment, make sure the request is at least that big, + then call clip_heap_chunk_size, then make sure the result is >= request. */ asize_t caml_round_heap_chunk_size (asize_t request) { asize_t result = request; + uintnat incr; + + /* Compute the heap increment as a byte size. */ + if (caml_major_heap_increment > 1000){ + incr = Bsize_wsize (caml_major_heap_increment); + }else{ + incr = caml_stat_heap_size / 100 * caml_major_heap_increment; + } - if (result < caml_major_heap_increment){ - result = caml_major_heap_increment; + if (result < incr){ + result = incr; } result = clip_heap_chunk_size (result); diff --git a/byterun/memory.h b/byterun/memory.h index 07610701..9befa873 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -266,27 +266,31 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ 0) #define CAMLlocal1(x) \ - value x = 0; \ + value x = Val_unit; \ CAMLxparam1 (x) #define CAMLlocal2(x, y) \ - value x = 0, y = 0; \ + value x = Val_unit, y = Val_unit; \ CAMLxparam2 (x, y) #define CAMLlocal3(x, y, z) \ - value x = 0, y = 0, z = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit; \ CAMLxparam3 (x, y, z) #define CAMLlocal4(x, y, z, t) \ - value x = 0, y = 0, z = 0, t = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit; \ CAMLxparam4 (x, y, z, t) #define CAMLlocal5(x, y, z, t, u) \ - value x = 0, y = 0, z = 0, t = 0, u = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit, u = Val_unit; \ CAMLxparam5 (x, y, z, t, u) #define CAMLlocalN(x, size) \ - value x [(size)] = { 0, /* 0, 0, ... */ }; \ + value x [(size)]; \ + int caml__i_##x; \ + for (caml__i_##x = 0; caml__i_##x < size; caml__i_##x ++) { \ + x[caml__i_##x] = Val_unit; \ + } \ CAMLxparamN (x, (size)) diff --git a/byterun/misc.c b/byterun/misc.c index 6eeae0f1..6dc27d5c 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -12,6 +12,8 @@ /***********************************************************************/ #include +#include +#include #include "config.h" #include "misc.h" #include "memory.h" @@ -121,3 +123,39 @@ void caml_ext_table_free(struct ext_table * tbl, int free_entries) for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); caml_stat_free(tbl->contents); } + +CAMLexport char * caml_strdup(const char * s) +{ + size_t slen = strlen(s); + char * res = caml_stat_alloc(slen + 1); + memcpy(res, s, slen + 1); + return res; +} + +CAMLexport char * caml_strconcat(int n, ...) +{ + va_list args; + char * res, * p; + size_t len; + int i; + + len = 0; + va_start(args, n); + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + len += strlen(s); + } + va_end(args); + res = caml_stat_alloc(len + 1); + va_start(args, n); + p = res; + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + size_t l = strlen(s); + memcpy(p, s, l); + p += l; + } + va_end(args); + *p = 0; + return res; +} diff --git a/byterun/misc.h b/byterun/misc.h index 4fd82af2..5640980a 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -61,8 +61,6 @@ typedef char * addr; /* Assertions */ -/* */ - #ifdef DEBUG #define CAMLassert(x) \ ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) @@ -76,6 +74,13 @@ CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2) Noreturn; +/* Safe string operations */ + +CAMLextern char * caml_strdup(const char * s); +CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */ + +/* */ + /* Data structures */ struct ext_table { @@ -138,6 +143,13 @@ extern void caml_set_fields (char *, unsigned long, unsigned long); #define Assert CAMLassert #endif +/* snprintf emulation for Win32 */ + +#ifdef _WIN32 +extern int caml_snprintf(char * buf, size_t size, const char * format, ...); +#define snprintf caml_snprintf +#endif + /* */ #endif /* CAML_MISC_H */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index cbb1c7bf..268bcfe9 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -300,5 +300,6 @@ extern value caml_global_data; } #endif +CAMLextern value caml_set_oo_id(value obj); #endif /* CAML_MLVALUES_H */ diff --git a/byterun/obj.c b/byterun/obj.c index 8e00282e..b045fee2 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -247,3 +247,15 @@ value caml_cache_public_method2 (value *meths, value tag, value *cache) } } #endif /*CAML_JIT*/ + +static value oo_last_id = Val_int(0); + +CAMLprim value caml_set_oo_id (value obj) { + Field(obj, 1) = oo_last_id; + oo_last_id += 2; + return obj; +} + +CAMLprim value caml_int_as_pointer (value n) { + return n - 1; +} diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 8123d49b..8204205f 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -61,9 +61,8 @@ extern char * caml_dlerror(void); Return 0 on success, -1 on error; set errno in the case of error. */ extern int caml_read_directory(char * dirname, struct ext_table * contents); -#ifdef __linux__ -/* Recover executable name from /proc/self/exe if possible */ +/* Recover executable name if possible (/proc/sef/exe under Linux, + GetModuleFileName under Windows). */ extern int caml_executable_name(char * name, int name_len); -#endif #endif /* CAML_OSDEPS_H */ diff --git a/byterun/parsing.c b/byterun/parsing.c index 3c1ced7d..a857e392 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -63,7 +63,7 @@ struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[n]) #endif diff --git a/byterun/printexc.c b/byterun/printexc.c index 7e3259ab..a371a71f 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -53,8 +53,8 @@ CAMLexport char * caml_format_exception(value exn) buf.ptr = buf.data; buf.end = buf.data + sizeof(buf.data) - 1; - add_string(&buf, String_val(Field(Field(exn, 0), 0))); - if (Wosize_val(exn) >= 2) { + if (Tag_val(exn) == 0) { + add_string(&buf, String_val(Field(Field(exn, 0), 0))); /* Check for exceptions in the style of Match_failure and Assert_failure */ if (Wosize_val(exn) == 2 && Is_block(Field(exn, 1)) && @@ -71,7 +71,8 @@ CAMLexport char * caml_format_exception(value exn) if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); + snprintf(intbuf, sizeof(intbuf), + "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); @@ -82,7 +83,9 @@ CAMLexport char * caml_format_exception(value exn) } } add_char(&buf, ')'); - } + } else + add_string(&buf, String_val(Field(exn, 0))); + *buf.ptr = 0; /* Terminate string */ i = buf.ptr - buf.data + 1; res = malloc(i); @@ -92,7 +95,14 @@ CAMLexport char * caml_format_exception(value exn) } -void caml_fatal_uncaught_exception(value exn) +#ifdef NATIVE_CODE +# define DEBUGGER_IN_USE 0 +#else +# define DEBUGGER_IN_USE caml_debugger_in_use +#endif + +/* Default C implementation in case the OCaml one is not registered. */ +static void default_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; @@ -113,13 +123,21 @@ void caml_fatal_uncaught_exception(value exn) fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ - if (caml_backtrace_active -#ifndef NATIVE_CODE - && !caml_debugger_in_use -#endif - ) { + if (caml_backtrace_active && !DEBUGGER_IN_USE) caml_print_exception_backtrace(); - } +} + +void caml_fatal_uncaught_exception(value exn) +{ + value *handle_uncaught_exception; + + handle_uncaught_exception = + caml_named_value("Printexc.handle_uncaught_exception"); + if (handle_uncaught_exception != NULL) + /* [Printexc.handle_uncaught_exception] does not raise exception. */ + caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); + else + default_fatal_uncaught_exception(exn); /* Terminate the process */ exit(2); } diff --git a/byterun/startup.c b/byterun/startup.c index 7b9aad46..36972206 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -246,10 +246,10 @@ static int parse_command_line(char **argv) #endif case 'v': if (!strcmp (argv[i], "-version")){ - printf ("The OCaml runtime, version " OCAML_VERSION "\n"); + printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ - printf (OCAML_VERSION "\n"); + printf (OCAML_VERSION_STRING "\n"); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; @@ -350,9 +350,7 @@ CAMLexport void caml_main(char **argv) value res; char * shared_lib_path, * shared_libs, * req_prims; char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ @@ -369,12 +367,19 @@ CAMLexport void caml_main(char **argv) #endif parse_camlrunparam(); pos = 0; + + /* First, try argv[0] (when ocamlrun is called by a bytecode program) */ exe_name = argv[0]; -#ifdef __linux__ - if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) - exe_name = proc_self_exe; -#endif fd = caml_attempt_open(&exe_name, &trail, 0); + + /* Should we really do that at all? The current executable is ocamlrun + itself, it's never a bytecode program. */ + if (fd < 0 + && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { + exe_name = proc_self_exe; + fd = caml_attempt_open(&exe_name, &trail, 0); + } + if (fd < 0) { pos = parse_command_line(argv); if (argv[pos] == 0) @@ -425,7 +430,6 @@ CAMLexport void caml_main(char **argv) caml_oldify_one (caml_global_data, &caml_global_data); caml_oldify_mopup (); /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv + pos); #ifdef _WIN32 /* Start a thread to handle signals */ @@ -455,11 +459,9 @@ CAMLexport void caml_startup_code( char **argv) { value res; - char* cds_file; + char * cds_file; char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif caml_init_ieee_floats(); #ifdef _MSC_VER @@ -471,15 +473,12 @@ CAMLexport void caml_startup_code( #endif cds_file = getenv("CAML_DEBUG_FILE"); if (cds_file != NULL) { - caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1); - strcpy(caml_cds_file, cds_file); + caml_cds_file = caml_strdup(cds_file); } parse_camlrunparam(); exe_name = argv[0]; -#ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; -#endif caml_external_raise = NULL; /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, @@ -514,7 +513,6 @@ CAMLexport void caml_startup_code( caml_section_table = section_table; caml_section_table_size = section_table_size; /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); diff --git a/byterun/str.c b/byterun/str.c index 9a96147e..6effa91a 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -15,6 +15,8 @@ #include #include +#include +#include #include "alloc.h" #include "fail.h" #include "mlvalues.h" @@ -68,7 +70,7 @@ CAMLprim value caml_string_get16(value str, value index) intnat res; unsigned char b1, b2; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); #ifdef ARCH_BIG_ENDIAN @@ -84,7 +86,7 @@ CAMLprim value caml_string_get32(value str, value index) intnat res; unsigned char b1, b2, b3, b4; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -97,19 +99,12 @@ CAMLprim value caml_string_get32(value str, value index) return caml_copy_int32(res); } -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - CAMLprim value caml_string_get64(value str, value index) { - uint32 reshi; - uint32 reslo; + uint64 res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -119,13 +114,17 @@ CAMLprim value caml_string_get64(value str, value index) b7 = Byte_u(str, idx + 6); b8 = Byte_u(str, idx + 7); #ifdef ARCH_BIG_ENDIAN - reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; - reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; + res = (uint64) b1 << 56 | (uint64) b2 << 48 + | (uint64) b3 << 40 | (uint64) b4 << 32 + | (uint64) b5 << 24 | (uint64) b6 << 16 + | (uint64) b7 << 8 | (uint64) b8; #else - reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; - reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; + res = (uint64) b8 << 56 | (uint64) b7 << 48 + | (uint64) b6 << 40 | (uint64) b5 << 32 + | (uint64) b4 << 24 | (uint64) b3 << 16 + | (uint64) b2 << 8 | (uint64) b1; #endif - return caml_copy_int64(I64_literal(reshi,reslo)); + return caml_copy_int64(res); } CAMLprim value caml_string_set16(value str, value index, value newval) @@ -133,7 +132,7 @@ CAMLprim value caml_string_set16(value str, value index, value newval) unsigned char b1, b2; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); val = Long_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 8; @@ -152,7 +151,7 @@ CAMLprim value caml_string_set32(value str, value index, value newval) unsigned char b1, b2, b3, b4; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); val = Int32_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 24; @@ -175,30 +174,28 @@ CAMLprim value caml_string_set32(value str, value index, value newval) CAMLprim value caml_string_set64(value str, value index, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - uint32 lo,hi; int64 val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); val = Int64_val(newval); - I64_split(val,hi,lo); #ifdef ARCH_BIG_ENDIAN - b1 = 0xFF & hi >> 24; - b2 = 0xFF & hi >> 16; - b3 = 0xFF & hi >> 8; - b4 = 0xFF & hi; - b5 = 0xFF & lo >> 24; - b6 = 0xFF & lo >> 16; - b7 = 0xFF & lo >> 8; - b8 = 0xFF & lo; + b1 = 0xFF & val >> 56; + b2 = 0xFF & val >> 48; + b3 = 0xFF & val >> 40; + b4 = 0xFF & val >> 32; + b5 = 0xFF & val >> 24; + b6 = 0xFF & val >> 16; + b7 = 0xFF & val >> 8; + b8 = 0xFF & val; #else - b8 = 0xFF & hi >> 24; - b7 = 0xFF & hi >> 16; - b6 = 0xFF & hi >> 8; - b5 = 0xFF & hi; - b4 = 0xFF & lo >> 24; - b3 = 0xFF & lo >> 16; - b2 = 0xFF & lo >> 8; - b1 = 0xFF & lo; + b8 = 0xFF & val >> 56; + b7 = 0xFF & val >> 48; + b6 = 0xFF & val >> 40; + b5 = 0xFF & val >> 32; + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; #endif Byte_u(str, idx) = b1; Byte_u(str, idx + 1) = b2; @@ -299,3 +296,68 @@ CAMLprim value caml_bitvect_test(value bv, value n) int pos = Int_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } + +CAMLexport value caml_alloc_sprintf(const char * format, ...) +{ + va_list args; + char buf[64]; + int n; + value res; + +#ifndef _WIN32 + /* C99-compliant implementation */ + va_start(args, format); + /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest", including the terminating '\0'. + It returns the number of characters of the formatted string, + excluding the terminating '\0'. */ + n = vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + /* Allocate a Caml string with length "n" as computed by vsnprintf. */ + res = caml_alloc_string(n); + if (n < sizeof(buf)) { + /* All output characters were written to buf, including the + terminating '\0'. Just copy them to the result. */ + memcpy(String_val(res), buf, n); + } else { + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to vsnprintf is n+1. */ + va_start(args, format); + vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#else + /* Implementation specific to the Microsoft CRT library */ + va_start(args, format); + /* "_vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest". Let "len" be the number of characters of the formatted + string. + If "len" < "sz", a null terminator was appended, and "len" is returned. + If "len" == "sz", no null termination, and "len" is returned. + If "len" > "sz", a negative value is returned. */ + n = _vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + if (n >= 0 && n <= sizeof(buf)) { + /* All output characters were written to buf. + "n" is the actual length of the output. + Copy the characters to a Caml string of length n. */ + res = caml_alloc_string(n); + memcpy(String_val(res), buf, n); + } else { + /* Determine actual length of output, excluding final '\0' */ + va_start(args, format); + n = _vscprintf(format, args); + va_end(args); + res = caml_alloc_string(n); + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to _vsnprintf is n+1. */ + va_start(args, format); + _vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#endif +} diff --git a/byterun/sys.c b/byterun/sys.c index 332887b1..03ca1e3e 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -125,8 +125,7 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) int fd, flags, perm; char * p; - p = caml_stat_alloc(caml_string_length(path) + 1); - strcpy(p, String_val(path)); + p = caml_strdup(String_val(path)); flags = caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ @@ -145,46 +144,107 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) CAMLprim value caml_sys_close(value fd) { + caml_enter_blocking_section(); close(Int_val(fd)); + caml_leave_blocking_section(); return Val_unit; } CAMLprim value caml_sys_file_exists(value name) { +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - return Val_bool(stat(String_val(name), &st) == 0); +#endif + char * p; + int ret; + + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = stat(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + return Val_bool(ret == 0); } CAMLprim value caml_sys_is_directory(value name) { + CAMLparam1(name); +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - if (stat(String_val(name), &st) == -1) caml_sys_error(name); +#endif + char * p; + int ret; + + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = stat(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + if (ret == -1) caml_sys_error(name); #ifdef S_ISDIR - return Val_bool(S_ISDIR(st.st_mode)); + CAMLreturn(Val_bool(S_ISDIR(st.st_mode))); #else - return Val_bool(st.st_mode & S_IFDIR); + CAMLreturn(Val_bool(st.st_mode & S_IFDIR)); #endif } CAMLprim value caml_sys_remove(value name) { + CAMLparam1(name); + char * p; int ret; - ret = unlink(String_val(name)); + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); + ret = unlink(p); + caml_leave_blocking_section(); + caml_stat_free(p); if (ret != 0) caml_sys_error(name); - return Val_unit; + CAMLreturn(Val_unit); } CAMLprim value caml_sys_rename(value oldname, value newname) { - if (rename(String_val(oldname), String_val(newname)) != 0) + char * p_old; + char * p_new; + int ret; + p_old = caml_strdup(String_val(oldname)); + p_new = caml_strdup(String_val(newname)); + caml_enter_blocking_section(); + ret = rename(p_old, p_new); + caml_leave_blocking_section(); + caml_stat_free(p_new); + caml_stat_free(p_old); + if (ret != 0) caml_sys_error(NO_ARG); return Val_unit; } CAMLprim value caml_sys_chdir(value dirname) { - if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname); - return Val_unit; + CAMLparam1(dirname); + char * p; + int ret; + p = caml_strdup(String_val(dirname)); + caml_enter_blocking_section(); + ret = chdir(p); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret != 0) caml_sys_error(dirname); + CAMLreturn(Val_unit); } CAMLprim value caml_sys_getcwd(value unit) @@ -244,11 +304,8 @@ CAMLprim value caml_sys_system_command(value command) CAMLparam1 (command); int status, retcode; char *buf; - intnat len; - len = caml_string_length (command); - buf = caml_stat_alloc (len + 1); - memmove (buf, String_val (command), len + 1); + buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); status = system(buf); caml_leave_blocking_section (); @@ -385,9 +442,16 @@ CAMLprim value caml_sys_read_directory(value path) CAMLparam1(path); CAMLlocal1(result); struct ext_table tbl; + char * p; + int ret; caml_ext_table_init(&tbl, 50); - if (caml_read_directory(String_val(path), &tbl) == -1){ + p = caml_strdup(String_val(path)); + caml_enter_blocking_section(); + ret = caml_read_directory(p, &tbl); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret == -1){ caml_ext_table_free(&tbl, 1); caml_sys_error(path); } diff --git a/byterun/unix.c b/byterun/unix.c index 3fee9a39..be2c39b1 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -49,11 +49,10 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; - int n; + size_t n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; @@ -68,7 +67,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -76,18 +75,15 @@ char * caml_search_in_path(struct ext_table * path, char * name) if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - if (fullname[0] != 0) strcat(fullname, "/"); - strcat(fullname, name); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } #ifdef __CYGWIN32__ @@ -107,31 +103,28 @@ static int cygwin_file_exists(char * name) static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 6); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "/"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + caml_stat_free(fullname); + fullname = caml_strconcat(4, dir, "/", name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 5); - strcpy(fullname, name); - if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + if (cygwin_file_exists(name)) return caml_strdup(name); + fullname = caml_strconcat(2, name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; - strcpy(fullname, name); - return fullname; + caml_stat_free(fullname); + return caml_strdup(name); } #endif @@ -156,10 +149,10 @@ char * caml_search_exe_in_path(char * name) char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 4); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".so"); + + dllname = caml_strconcat(2, name, ".so"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; @@ -286,7 +279,6 @@ int caml_read_directory(char * dirname, struct ext_table * contents) #else struct direct * e; #endif - char * p; d = opendir(dirname); if (d == NULL) return -1; @@ -294,9 +286,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents) e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; - p = caml_stat_alloc(strlen(e->d_name) + 1); - strcpy(p, e->d_name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(e->d_name)); } closedir(d); return 0; @@ -321,4 +311,11 @@ int caml_executable_name(char * name, int name_len) return 0; } +#else + +int caml_executable_name(char * name, int name_len) +{ + return -1; +} + #endif diff --git a/byterun/win32.c b/byterun/win32.c index d807f690..67e96832 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -16,6 +16,7 @@ #include #include #include +#include #include #include #include @@ -43,8 +44,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) int n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; @@ -59,7 +59,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -67,56 +67,55 @@ char * caml_search_in_path(struct ext_table * path, char * name) if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "\\"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) continue; + /* not sure what empty path components mean under Windows */ + fullname = caml_strconcat(3, dir, "\\", name); caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; - DWORD pathlen, retcode; + size_t fullnamelen; + DWORD retcode; - pathlen = strlen(name) + 1; - if (pathlen < 256) pathlen = 256; + fullnamelen = strlen(name) + 1; + if (fullnamelen < 256) fullnamelen = 256; while (1) { - fullname = caml_stat_alloc(pathlen); + fullname = caml_stat_alloc(fullnamelen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ - pathlen, + fullnamelen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - strcpy(fullname, name); - break; + caml_stat_free(fullname); + return caml_strdup(name); } - if (retcode < pathlen) break; + if (retcode < fullnamelen) + return fullname; caml_stat_free(fullname); - pathlen = retcode + 1; + fullnamelen = retcode + 1; } - return fullname; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 5); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".dll"); + + dllname = caml_strconcat(2, name, ".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; @@ -235,27 +234,27 @@ static void expand_argument(char * arg) static void expand_pattern(char * pat) { + char * prefix, * p, * name; int handle; struct _finddata_t ffblk; - int preflen; + size_t i; handle = _findfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } - for (preflen = strlen(pat); preflen > 0; preflen--) { - char c = pat[preflen - 1]; - if (c == '\\' || c == '/' || c == ':') break; + prefix = caml_strdup(pat); + for (i = strlen(prefix); i > 0; i--) { + char c = prefix[i - 1]; + if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; } } do { - char * name = malloc(preflen + strlen(ffblk.name) + 1); - if (name == NULL) out_of_memory(); - memcpy(name, pat, preflen); - strcpy(name + preflen, ffblk.name); + name = caml_strconcat(2, prefix, ffblk.name); store_argument(name); } while (_findnext(handle, &ffblk) != -1); _findclose(handle); + caml_stat_free(prefix); } @@ -278,7 +277,7 @@ CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) int caml_read_directory(char * dirname, struct ext_table * contents) { - int dirnamelen; + size_t dirnamelen; char * template; #if _MSC_VER <= 1200 int h; @@ -286,28 +285,27 @@ int caml_read_directory(char * dirname, struct ext_table * contents) intptr_t h; #endif struct _finddata_t fileinfo; - char * p; dirnamelen = strlen(dirname); - template = caml_stat_alloc(dirnamelen + 5); - strcpy(template, dirname); - switch (dirname[dirnamelen - 1]) { - case '/': case '\\': case ':': - strcat(template, "*.*"); break; - default: - strcat(template, "\\*.*"); - } + if (dirnamelen > 0 && + (dirname[dirnamelen - 1] == '/' + || dirname[dirnamelen - 1] == '\\' + || dirname[dirnamelen - 1] == ':')) + template = caml_strconcat(2, dirname, "*.*"); + else + template = caml_strconcat(2, dirname, "\\*.*"); h = _findfirst(template, &fileinfo); - caml_stat_free(template); - if (h == -1) return errno == ENOENT ? 0 : -1; + if (h == -1) { + caml_stat_free(template); + return errno == ENOENT ? 0 : -1; + } do { if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { - p = caml_stat_alloc(strlen(fileinfo.name) + 1); - strcpy(p, fileinfo.name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(fileinfo.name)); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); + caml_stat_free(template); return 0; } @@ -502,3 +500,42 @@ void caml_install_invalid_parameter_handler() } #endif + + +/* Recover executable name */ + +int caml_executable_name(char * name, int name_len) +{ + int retcode; + + int ret = GetModuleFileName(NULL, name, name_len); + if (0 == ret || ret >= name_len) return -1; + return 0; +} + +/* snprintf emulation */ + +int caml_snprintf(char * buf, size_t size, const char * format, ...) +{ + int len; + va_list args; + + if (size > 0) { + va_start(args, format); + len = _vsnprintf(buf, size, format, args); + va_end(args); + if (len >= 0 && len < size) { + /* [len] characters were stored in [buf], + a null-terminator was appended. */ + return len; + } + /* [size] characters were stored in [buf], without null termination. + Put a null terminator, truncating the output. */ + buf[size - 1] = 0; + } + /* Compute the actual length of output, excluding null terminator */ + va_start(args, format); + len = _vscprintf(format, args); + va_end(args); + return len; +} diff --git a/camlp4/.ignore b/camlp4/.ignore deleted file mode 100644 index 481c691a..00000000 --- a/camlp4/.ignore +++ /dev/null @@ -1,2 +0,0 @@ -.cache-status -*.tmp.ml diff --git a/camlp4/CHANGES b/camlp4/CHANGES deleted file mode 100644 index 0251cd16..00000000 --- a/camlp4/CHANGES +++ /dev/null @@ -1,898 +0,0 @@ -- [...] - In the revised syntax of parsers the "?" is now a "??" like in the orignal - syntax to not conflict with optional labels. - -- [29 Jun 05] Add private row types. Make "private" a type constructor - "TyPrv" rather than a flag. (Jacques) - -- [09 Jun 04] Moved "-no_quot" option from pa_o to camlp4, enabling to - use it indepently fom pa_o.cmo. - -- [17 Nov 04] Renamed "loc" into "_loc", introducing an incompatibility - with existing code (3.08.x and before). Such code can generally run - unmodified using the -loc option (camlp4 -loc "loc"). - -Camlp4 Version 3.08.2 ------------------------- -- [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli: - - plexer.mli: introduced a new lexer building function `make_lexer', - similar to `gmake', but returning a triple of references in addition - (holding respectively the character number of the beginning of the - current line, the current line number and the name of the file being - parsed). - - pcaml.mli: a new value `position'. A global reference to a triple like - the one mentioned above. -- [07 Sep 04] Camlp4 grammars `error recovery mode' now issues a warning - when used (but this warning is disabled by default). - -Camlp4 Version 3.08.[01] ------------------------- -- [05 Jul 04] creation of the `unmaintained' directory: - pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml - go there, each in its own subdir. Currently, they compile fine. -- [05 Jul 04] pa_ifdef, subsumed by pa_macro since 3.07, prints a warning - when loaded, encouraging use of pa_macro. -- [01 July 04] profiled versions of Camlp4 libs are *NOT* installed - by default (not even built). To build and install them, uncomment - the line PROFILING=prof in camlp4/config/Makefile.tpl, and then - make opt.opt && make install -- [22-23 June 04] `make install' now installs also pa_[or].cmx, pa_[or]p.cmx, - pa_[or]_fast.cmx, and odyl.cmx -- [12 may 04] Added to the camlp4 tools the -version option that prints - the version number, in the same way as the other ocaml tools. -- [12 may 04] Locations are now handled as in OCaml. The main benefit - is that line numbers are now correct in error messages. However, this - slightly changes the interface of a few Camlp4 modules (see ICHANGES). - ** Warning: Some contribs of the camlp4 distribution are broken because - of this change. In particular the scheme/lisp syntaxes. -- [20 nov 03] Illegal escape sequences in strings now issue a warning. - -Camlp4 Version 3.07 -___________________ - -- [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6. -- [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in - both parsers (ocaml and revised). There was, afaik, no other way to fix - ambiguities (bugs) in parsing labels and type constraints. - -Camlp4 Version 3.07 beta1 -________________________ - -- [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4 - "parallel" CVS tree, which becomes obsolete from now on. - Added support for recursive modules, private data constructors, and - new syntaxes for integers (int32, nativeint, ...). - -Camlp4 Version 3.06++ ------------------------ - -- [02 Dec 02] In AST predefined quotation, changed antiquotations for - "rec", "mutable": now all are with coercion "opt": $opt:...$ (instead - of "rec" and "mut"). Added antiquotation for "private". Cleaned up - the entries for "methods" and for labelled and optional parameters. -- [29 Nov 02] Removed all "extract_crc" stuff no more necessary with - the new interface of Dynlink. -- [26 Nov 02] Added ability to use "#use" directives in compiled files. -- [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file" - is written: # (load "file"). Added directives in "implem", "interf" and - "use" directive. -- [20 Nov 02] Added Grammar.glexer returning the lexer used by a - grammar. Also added a field in Token.glexer type to ask lexers to - record the locations of the comments. -- [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo): - don't parse quotations (it allows to use e.g. <:> as a valid token). -- [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is - kept for compatibility, but deprecated). The extended statements - allow de definitions of macros and conditional compilation like - in C. -- [29 Oct 02] Changed pretty printers of the three main syntaxes: if - the locations of input are not correct, do no more raise End_of_file - when displaying the inter-phrases (return: the input found up to eof - if not empty, otherwise the value of the -sep parameter if not empty, - otherwise the string "\n"). -- [25 Oct 02] Added option -records in pa_sml.cmo: generates normal - OCaml records instead of objects (the user must be sure that there - are no names conflicts). -- [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the - next call to Plexer.gmake returns a lexer where the dot preceded by - spaces (space, tab, newline, etc.) return a different token than when - not preceded by spaces. -- [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the - extension pr_schemep.cmo which rebuilts parsers. -- [15 Oct 02] Now, in case of syntax error, the real input file name is - displayed (can be different from the input file, because of the possibility - of line directives, typically generated by /lib/cpp). - Changed interface of Stdpp.line_of_loc: now return also a string: the name - of the real input file name. -- [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors - with currification of parameters (C x y) were accepted. -- [14 Oct 02] Fixed many problems of make under Windows (in particular if - installations directories contain spaces). -- [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities - with the ocaml yacc version of the compiler): 1/ "ref new foo" was - interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary - minuses did not work correctly (nor in quotation of syntax trees), in - particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()". -- [Sep-Oct 02] Many changes and improvements in Scheme syntax. -- [07 Oct 02] Added definition of Pcaml.type_declaration which is - now visible in the interface, allowing to change the type declarations. -- [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test - it and take different decision. In revised syntax, its value is "Revised", - in normal syntax "OCaml" and in Scheme syntax "Scheme". -- [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number. -- [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing - comment: (* bleble'''*) -- [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string" - without location (syntaxes pa_o and pa_r). -- [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry - to iterate a grammar entry and transitively all the entries it calls. -- [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give - ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml) - when generating its identifiers. -- [09 Sep 02] Fixed bug under toplevel, the command: - !Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");; - failed "End_of_file". -- [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr, - Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string. - E.g. in the toplevel: - # #load "pr_o.cmo"; - # Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;; - - : string = "let x = 3 in x + 2" - -Camlp4 Version 3.06 --------------------- - -- [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel), - camlp4sch (command). - -Camlp4 Version 3.05 ------------------------ - -- [12 Jul 02] Better treatment of comments in option -cip (add comments - in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo - (revised syntax); added comments before let binding and class - structure items; treat comments inside sum and record type definitions; - the option -tc is now deprecated and equivalent to -cip. -- [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee - left evaluation of functions parameters, t-uples, and so on (instead of - the default non-specified-but-in-fact-right-to-left evaluation). -- [06 Jun 02] Changed revised syntax (pa_r) of variants types definition; - (Jacques Garrigue's idea): - old syntax new syntax - [| ... |] [ = ... ] - [| < ... |] [ < ... ] - [| > ... |] [ > ... ] - This applies also in predefined quotations of syntax tree for types - <:ctyp< ... >> -- [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons; - and the option -no_ss is now by default. -- [30 May 02] Improved SML syntax (pa_sml). -- [30 May 02] Changed the AST for the "with module" construct (was with - type "module_type"; changed into type "module_expr"). -- [26 May 02] Added missing abstract module types. -- [21 Apr 02] Added polymorphic types for polymorphic methods: - revised syntax (example): ! 'a 'b . type - ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >> -- [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on - the "dot" on (in interface file file): - class c : a * B.c -> object val x : int end -- [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated". -- [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be - displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo). -- [03 Apr 02] When there are several tokens parsed together (locally LL(n)), - the location error now highlights all tokens, resulting in a more clear - error message (e.g. "for i let" would display "illegal begin of expr" - and highlight the 3 tokens, not just "for"). -- [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar - symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial - parameters: a function of type 'a -> 'b -> 'b doing the fold and an - initial value of type 'b. Actually, LIST0 now is like - FOLD0 (fun x y -> x :: y) [] - with an reverse of the resulting list. -- [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4 - as a script, the camlp4 welcome message was displayed. -- [14 Mar 02] The configure shell and the program now test the consistency - of OCaml and Camlp4. Therefore 1/ if trying to compile this version with - an incompatible OCaml version or 2/ trying to run an installed Camlp4 with - a incompatible OCaml version: in both cases, camlp4 fails. -- [14 Mar 02] When make opt.opt is done, the very fast version is made for - the normal syntax ("compiled" version). The installed camlp4o.opt is that - version. -- [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >> - and <:expr< x.val := e >> which generates now the tree of !x and x := e, - no more x.contents and x.contents <- e. This change was necessary because - of a problem if a record has been defined with a field named "contents". - -- [16 Feb 02] Changed interface of grammars: the token type is now - customizable, using a new lexer type Token.glexer, parametrized by - the token type, and a new functor GMake. This was accompanied by - some cleanup. Become deprecated: the type Token.lexer (use Token.glexer), - Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use - Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake). - Deprecated means that they are kept during some versions and removed - afterwards. -- [06 Feb 02] Added missing infix "%" in pa_o (normal syntax). -- [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry - and having the Format.formatter as first parameter (Grammar.Entry.print - and its equivalent in functorial interface call it). -- [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the - quotations are no more lexed in all lexers built by Plexer.make () -- [05 Feb 02] Changed the printing of options so that the option -help - aligns correctly their documentation. One can use now Pcaml.add_option - without having to calculate that. -- [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is - by default, because its behaviour is not 100% sure. An option -cip has - been added to set it. -- [03 Feb 02] Added function Stdpp.line_of_loc returning the line and - columns positions from a character location and a file. -- [01 Feb 02] Fixed bug in token.ml: the location function provided by - lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location - could raise Invalid_argument "Array.make" for big files if the number - of read tokens overflows the maximum arrays size (Sys.max_array_length). - The bug is not really fixed: in case of this overflow, the returned - location is (0, 0) (but the program does not fail). -- [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack - had to be programmed to be able to treat them correctly. -- [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives - were not applied in the good order. -- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND - statements (before it tried only the EXTEND). -- [23 Jan 02] The empty functional stream "fstream [: :]" is now of type - 'a Fstream.t thanks to the new implementation of lazies allowing to - create polymorphic lazy values. -- [11 Jan 02] Added a test in grammars using Plexer that a keyword is not - used also as parameter of a LIDENT or a UIDENT. -- [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions - with several currified parameters did not work. It works now, but the - previous code was supposed to treat let ("fun" in SML syntax) definitions - of infix operators, what does not work any more now. -- [04 Jan 02] Alain Frisch's contribution: - Added pa_ocamllex.cma, syntax for ocamllex files. The command: - camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml - does the same thing as: - ocamllex foo.mll - Allow to compile directly mll files. Without option -ocamllex, allow - to insert lex rules in a ml file. -- [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option - string) to specify the string to print between phrases in pretty printers. - The default is None, meaning to copy the inter phrases from the source - file. - -Camlp4 Version 3.04 -------------------- - -- [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to - specify the parsers tof use, i.e. now can use other parsing technics - than the Camlp4 grammar system. -- [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which - returned bad values, resulting lexing of backslash sequences incompatible - with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns - the string of the two characters \ and 1). -- [15 Nov 01] In revised syntax, in let binding in sequences, the "in" - can be replaced by a semicolon; the revised syntax printer pr_r.cmo - now rather prints a semicolon there. -- [07 Nov 01] Added the ability to use $ as token: was impossible so far, - because of AST quotation uses it for its antiquotation. The fix is just - a little (invisible) change in Plexer. -- [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r - try to print comments inside sum and record types like they are in - the source (not by default, because may work incorrectly). -- [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r: - print ocamldoc comments after the declarations, when they are before. -- [04 Nov 01] Added locations for variants and labels declarations in AST - (file MLast.mli). -- [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line - when displaying the sources between phrase, to prevent e.g. the displaying - of the possible last comment of a sum type declaration (the other comment - being not displayed anyway). -- [24 Oct 01] Fixed incorrect locations in sequences. -- [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead - of the generated ocamlc. Fixed. -- [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc: - in parsers, in labels. -- [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard - syntax (pa_o). - -Camlp4 Version 3.03 -------------------- - -- [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed - some syntaxes of labels patterns. Added missing case in exception - declaration (exception rebinding). -- [05 Oct 01] Fixed bug in normal syntax: when defining a constructor - named "True" of "False" (capitalized, i.e. not like the booleans), it - did not work. -- [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes - and types (cleaner). Cleaned up also several parts of the parsers. -- [02 Oct 01] In revised syntax, the warning for using old syntax for - sequences is now by default. To remove it, the option -no-warn-seq - of camlp4r has been added. Option -warn-seq has been removed. -- [07 Sep 01] Included Camlp4 in OCaml distribution. -- [06 Sep 01] Added missing pattern construction #t -- [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused. -- [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0 - (minus float) as pattern. -- [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed - identically. -- [20 Aug 01] Fixed configure script for Windows configuration. -- [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing - problem. -- [10 Aug 01] Fixed bug in compilation process under Windows: the use of - the extension .exe was missing in several parts in Makefiles and shell - scripts. -- [09 Aug 01] Changed message error in grammar: in the case when the rule - is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other), - where the grammar is locally LL(n), it displays now: - tok1 tok2 .. tokn expected - instead of just - tok1 expected - because "tok1" can be correct in the input, and in this case, the message - underscored the tok1 and said "tok1 expected". -- [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are - now displayed in revised syntax. -- [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and - class_sig_item to be able to generate several items from one only item - (like in str_item and sig_item). - -Camlp4 Version 3.02 -------------------- - -- [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted - in a typing error. -- [13 Jul 01] Fixed bug: did not accept floats in patterns. -- [11 Jul 01] Added function Pcaml.top_printer to be able to use the - printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer - of OCaml toplevel. Ex: - let f = Pcaml.top_printer Pcaml.pr_expr;; - #install_printer f;; - #load "pr_o.cmo";; -- [24 Jun 01] In grammars, added symbol ANY, returning the current token, - whichever it is. -- [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ] - is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ] - instead of [ _ = s1 -> () | _ = s2 -> () .. ] -- [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and - [Plexer.string_of_string_token] into module [Token] with names - [Token.eval_char] and [Token.eval_string]. -- [22 Jun 01] Added warning when using old syntax for sequences, while - and do (do..return, do..done) in predefined quotation expr. -- [22 Jun 01] Changed message for unbound quotations (more clear). - -Camlp4 Version 3.01.6: ----------------------- - -- [22 Jun 01] Changed the module Pretty into Spretty. -- [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed: - in the directory "config", the file "configure_batch" is a possibility - to configure the compilation (alternative of "configure" of the top - directory) and has a parameter "-ocaml-top" to specify the OCaml top - directory (relative to the camlp4/config directory). -- [21 Jun 01] The interactive "configure" now tests if the native-code - compilers ocamlc.opt and ocamlopt.opt are accessible and tell the - Makefile to preferably use them if they are. -- [16 Jun 01] The syntax tree for strings and characters now represent their - exact input representation (the node for characters is now of type string, - no more char). For example, the string "a\098c" remains "a\098c" and is - *not* converted into (the equivalent) "abc" in the syntax tree. The - convertion takes place when converting into OCaml tree representation. - This has the advantage that the pretty print now display them as they - are in the input file. To convert from input to real representation - (if needed), two functions have been added: Plexer.string_of_string_token - and Plexer.char_of_char_token. -- [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short - form for {foo = fun x -> y}. -- [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants. -- [06 Jun 01] Completed missing cases in abstract syntax tree and in normal - syntax parser pa_o.ml (about classes). -- [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not - work, and actually all prefix operators between parentheses. - -Camlp4 Version 3.01.5: ----------------------- - -- [04 Jun 01] Fixed bug: when using "include" in a structure item the rest - of the structure was lost. -- [31 May 01] Added ability to user #load and #directory inside ml or mli - files to specify a cmo file to be loaded (for syntax extension) or the - directory path (like option -I). Same semantics than in toplevel. -- [29 May 01] The name of the location variable used in grammars (action - parts of the rules) and in the predefined quotations for OCaml syntax - trees is now configurable in Stdpp.loc_name (string reference). Added also - option -loc to set this variable. Default: loc. -- [26 May 01] Added functional streams: a library module Fstream and a syntax - kit: pa_fstream.cmo. Syntax: - streams: fstream [: ... :] - parsers: fparser [ [: ... :] -> ... | ... ] -- [25 May 01] Added function Token.lexer_func_of a little bit more general - than Token.lexer_func_of_parser. - -Camlp4 Version 3.01.4: ----------------------- - -- [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables - resulting incorrect program: - (e.g. fun s -> parser [: `_; x :] -> s x was printed: - fun s -> parser [: `_; s :] -> s s) -- [19 May 01] Small improvement in pretty.ml resulting a faster print (no - more stacked HOVboxes which printers pr_r and pr_o usually generate in - expr, patt, ctyp, etc.) -- [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex] - in module [Token] to create lexers functions from char stream parsers - or from [ocamllex] lexers. -- [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep - comments inside phrases. -- [15 May 01] Changed pretty printing system, using now new extensible - functions of Camlp4. -- [15 May 01] Added library module Extfun for extensible functions, - syntax pa_extfun, and a printer pr_extfun. -- [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of - "for", "while", and some other expressions, when between parentheses. - -Camlp4 Version 3.01.3: ----------------------- - -- [04 May 01] Put back the syntax "do ... return ..." in predefined - quotation "expr", to be able to compile previous programs. Work - only if the quotation is in position of expression, not in pattern. -- [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated). -- [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use, - the display was incorrect: it displayed the input, instead of the - file location. - -Camlp4 Version 3.01.2: ----------------------- - -- [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of - command camlp4 to display more information in case of parsing error. -- [27 Apr 01] Fixed bug: the locations in sequences was not what expected - by OCaml, resulting on bad locations displaying in case of typing error. -- [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed - of left associative instead of right associative, resulting bad pretty - printing. - -Camlp4 Version 3.01.1: ----------------------- - -- [19 Apr 01] Added missing new feature "include" (structure item). -- [17 Apr 01] Changed revised syntax of sequences. Now: - do { expr1; expr2 ..... ; exprn } - for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn } - while expr do { expr1; expr2 ..... ; exprn } - * If holding a "let ... in", the scope applies up to the end of the sequence. - * The old syntax "do .... return ..." is still accepted. - * In expr quotation, it is *not* accepted. To ensure backward - compatibility, use ifdef NEWSEQ, which answers True from this version. - * The printer pr_r.cmo by default prints with this new syntax. - * To print with old syntax, use option -old_seq. - * To get a warning when using old syntax, use option -warn_seq. - -Camlp4 Version 3.01: --------------------- - -- [5 Mar 01] In pa_o.ml fixed problem, did not parse: - class ['a, 'b] cl a b : ['a, 'b] classtype -- [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning - that the user probably forgot to initialize it). -- [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of - let (f : unit -> int) = fun () -> 1 -- [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in - toplevel. -- [24 May 00] Changed the "make opt", returning to what was done in the - previous releases, i.e. just the compilation of the library (6 files). - The native code compilation of "camlp4o" and "camlp4r" are not absolutely - necessary and can create problems in some systems because of too long code. - The drawbacks are more important than the advantages. -- [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into - -split_ext: it applies now also for non functorial grammars (extended by - EXTEND instead of GEXTEND). -- [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing - of the construction "match x with parser" did not work (because of the - type constraint "Stream.t _" added some versions ago). - -Camlp4 Version 3.00: --------------------- - -- [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax. -- [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt -- [Apr 17, 00] Added support for labels and variants. -- [Mar 28, 00] Improved the grammars: now the rules starting with n - terminals are locally LL(n), i.e. if any of the terminal fails, it is - not Error but just Failure. Allows to write the OCaml syntax case: - ( operator ) - ( expr ) - with the problem of "( - )" as: - "("; "-"; ")" - "("; operator; ")" - "("; expr; ")" - after factorization of the "(", the rule "-"; ")" is locally LL(2): it - works for this reason. In the previous implementation, a hack had to be - added for this case. - - To allow this, the interface of "Token" changed. The field "tparse" is - now of type "pattern -> option (Stream.t t -> string)" instead of - "pattern -> Stream.t t -> string". Set it to "None" for standard pattern - parsing (or if you don't know). - -Camlp4 Version 2.04: --------------------- - -- [Nov 23, 99] Changed the module name Config into Oconfig, because of - conflict problem when applications want to link with the module Config of - OCaml. - -Camlp4 Version 2.03: --------------------- - -* pr_depend: - - [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C. - - [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a - bad dependency with file "bar.ml" if existed. And changed "pa_r.ml" - (revised syntax parsing) to generate a more logical ast for case - "var.Mod.lab". - - [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo". - - [Mar 11, 99] Added missing cases in "pr_depend.cmo". - - [Mar 9, 99] Added missing case in pr_depend.ml. - -* Other: - - [Sep 10, 99] Updated from current OCaml new interfaces. - - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same - change in OCaml. - - [Jun 24, 99] Added missing "constraint" construction in types - - [Jun 15, 99] Added option -I for command "mkcamlp4". - - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp - - [May 10, 99] Added shell script "configure_batch" in directory "config". - - [May 10, 99] Changed LICENSE to BSD. - - [Apr 29, 99] Added "ifdef" for mli files. - - [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo. - - [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed. - - [Mar 24, 99] Added missing stream type constraint for parsers. - - [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt - by default, instead of ocamlc and ocamlopt. - - [Mar 9, 99] Added ifndef in pa_ifdef.ml. - - [Mar 7, 99] Completed and fixed some cases in pr_extend.ml. - -Camlp4 Version 2.02: --------------------- - -* Parsing: - - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the - program example: "type t = F(B).t" - - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()". - - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo". - - [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax - -* Printing: - - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. - - [Dec 28, 98] Fixed pretty printing of long strings starting with spaces; - used to display "\\n..." instead of "\\n...". - -* Camlp4: - - [Feb 19, 99] Sort command line argument list in reverse order to - avoid argument names conflicts when adding arguments. - -* Olabl: - - [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some - changes in MLast. Olabl programs can be preprocessed by: - camlp4 pa_labl.cma pr_ldump.cmo - -* Internal: - - Use of pr_depend.cmo instead of ocamldep for dependencies. - -Camlp4 Version 2.01: --------------------- - -Token interface -* Big change: the type for tokens and tokens patterns is now (string * string) - the first string being the constructor name and the second its possible - parameters. No change in EXTEND statements using Plexer. But lexers - have: - - a supplementary parameter "tparse" to specify how to parse token - from token patterns. - - fields "using" and "removing" replacing "add_keyword" and - "remove_keyword". - See the file README-2.01 for how to update your programs and the interface - of Token. - -Grammar interface -* The function "keywords" have been replaced by "tokens". The equivalent - of the old statement: - Grammar.keywords g - is now: - Grammar.tokens g "" - -Missing features added -* Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) -* Added print "assert" statement (pr_o.cmo, pr_r.cmo) -* Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo - -Compilation -* Added "make scratch" -* Changed Makefile. No more "make T=../", working bad in some systems. -* Some changes to make compilation in Windows 95/98 working better (thanks - to Patricia Peratto). - -Classes and objects -* Added quotations for classes and objects (q_MLast.ml) -* Added accessible entries in module Pcaml (class_type, class_expr, etc.) -* Changed classes and objects types in definition (module MLast) - -Miscelleneous -* Some adds in pa_sml.cmo. Thanks to Franklin Chen. -* Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do - not print comments between phrases. -* Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND - by functions to turn around a PowerPC problem. - -Bug fixes -* Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)" -* Fixed printing pr_o.cmo of "(a.b <- 1)::1" -* Extended options with parameters worked only when the parameter was sticked. - Ex: - camlp4o pr_o.cmo -l120 foo.ml - worked, but not: - camlp4o pr_o.cmo -l 120 foo.ml - -Camlp4 Version 2.00: --------------------- - -* Designation "righteous" has been renamed "revised". -* Added class and objects in OCaml printing (pr_o.cmo), revised parsing - (pa_r.cmo) and printing (pr_r.cmo). -* Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused. - -Camlp4 Version 2.00--1: ------------------------ - -* Added classes and objects in OCaml syntax (pa_o.cmo) -* Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o - -Camlp4 Version 2.00--: ----------------------- - -* Adapted for OCaml 2.00. -* No objects and classes in this version. - -* Added "let module" parsing and printing. -* Added arrays patterns parsing and printing. -* Added records with "with" "{... with ...}" parsing and printing - -* Added # num "string" in plexer (was missing). -* Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;; -* Added "pa_sml.cmo", SML syntax + "lib.sml" -* Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding -* Changed Plexer: unknown keywords do not raise error but return Tterm -* q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work) -* Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded -* Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo -* Command ocpp works now without having to explicitely load - "/usr/local/lib/ocaml/stdlib.cma" and - "/usr/local/lib/camlp4/gramlib.cma" - -* Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes -* Added missing statement "include" in signature item in normal and righteous - syntaxes -* Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o): - now before "or", like in OCaml compiler. -* Same change in righteous syntax, by symmetry. - -Camlp4 Version 1.07.2: ----------------------- - -Errors and missings in normal and righteous syntaxes. - -* Added forgotten syntax (righteous): type constraints in class type fields. -* Added missing syntax (normal): type foo = bar = {......} -* Added missing syntax (normal): did not accept separators before ending - constructions (many of them). -* Fixed bug: "assert false" is now of type 'a, like in OCaml. -* Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4. -* Fixed bug in Windows NT/95: problem in backslash before newlines in strings - -Grammars, EXTEND, DELETE_RULE - -* Added functorial version for grammars (started in version 1.07.1, - completed in this version). -* Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial - version. -* EXTEND statement is added AFTER "top" instead of LEVEL "top" (because - of problems parsing "a; EXTEND...") -* Added ability to have expressions (in antiquotation form) of type string in - EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as - in others constructions inside EXTEND. -* A grammar rule hidden by another is not deleted but just masked. DELETE_RULE - will restore the old version. -* DELETE_RULE now raises Not_found if no rule matched. -* Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of - another rule. -* Some functions for "system use" in [Grammar] become "official": - [Entry.obj], [extend], [delete_rule]. - -Command line, man page - -* Added option -o: output on file instead of standard output, necessary - to allow compilation in Windows NT/95 (in fact, this option exists since - 1.07.1 but forgotten in its "changes" list). -* Command line option -help more complete. -* Updated man page: camlp4 options are better explained. -* Fixed bug: "camlp4 [other-options] foo.ml" worked but not - "camlp4 foo.ml [other-options]". -* Fixed bug: "camlp4 foo" did not display a understandable error message. - -Camlp4's compilation - -* Changes in compilation process in order to try to make it work better for - Windows NT under Cygnus. - -Miscellaneous - -* Added [Pcaml.add_option] for adding command line options. - -Camlp4 Version 1.07.1: ----------------------- - -* Added forgotten syntax in pr_o: type x = y = A | B -* Fixed bug negative floats parsing in pa_o => error while pretty printing -* Added assert statement and option -noassert. -* Environment variable CAMLP4LIB to change camlp4 library directory -* Grammar: empty rules have a correct location instead of (-1, -1) -* Compilation possible in Windows NT/95 -* String constants no more shared while parsing OCaml -* Fixed bug in antiquotations in q_MLast.cmo (bad errors locations) -* Fixed bug in antiquotations in q_MLast.cmo (EOI not checked) -* Fixed bug in Plexer: could not create keywords with iso 8859 characters - -Camlp4 Version 1.07: --------------------- - -* Changed version number + configuration script -* Added iso 8859 uppercase characters for uidents in plexer.ml -* Fixed bug factorization IDENT in grammars -* Fixed bug pr_o.cmo was printing "declare" -* Fixed bug constructor arity in OCaml syntax (pa_o.cmo). -* Changed "lazy" into "slazy". -* Completed pa_ifdef.cmo. - -Camlp4 Version 1.06: --------------------- - -* Adapted to OCaml 1.06. -* Changed version number to match OCaml's => 1.06 too. -* Deleted module Gstream, using OCaml's Stream. -* Generate different AST for C(x,y) and C x y (change done in OCaml's compiler) -* No more message "Interrupted" in toplevel in case of syntax error. -* Added flag to suppress warnings while extending grammars. -* Completed some missing statements and declarations (objects) -* Modified odyl implementation; works better -* Added ability to extend command line specification -* Added "let_binding" as predefined (accessible) entry in Pcaml. -* Added construction FUNCTION in EXTEND statement to call another function. -* Added some ISO-8859-1 characters in lexer identifiers. -* Fixed bug "value x = {val = 1};" (righteous syntax) -* Fixed bug "open A.B.C" was interpreted as "open B.A.C" -* Modified behavior of "DELETE_RULE": the complete rule must be provided -* Completed quotations MLast ("expr", "patt", etc) to accept whole language -* Renamed "LIKE" into "LEVEL" in grammar EXTEND -* Added "NEXT" as grammar symbol in grammar EXTEND -* Added command "mkcamlp4" to make camlp4 executables linked with C code -* Added "pr_extend.cmo" to reconstitute EXTEND instructions - -Camlp4 Version 0.6: -------------------- - ---- Installing - -* To compile camlp4, it is no more necessary to have the sources of the - Objective Caml compiler available. It can be compiled like any other - Objective Caml program. - ---- Options of "camlp4" - -* Added option -where: "camlp4 -where" prints the name of the standard - library directory of Camlp4 and exit. So, the ocaml toplevel and the - compiler can use the option: - -I `camlp4 -where` - -* Added option -nolib to not search for objects files in the installed - library directory of Camlp4. - ---- Interface of grammar library modules - -* The function Grammar.keywords returns now a list of pairs. The pair is - composed of a keyword and the number of times it is used in entries. - -* Changed interface of Token and Grammar for lexers, so user lexers have - to be changed. - ---- New features in grammars - -* New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules. - Ex: - DELETE_RULE Pcaml.expr: "if" END; - deletes the "if" instruction of the language. - -* Added the ability to parse some specific integer in grammars: a possible - parameter to INT, like the ones for LIDENT and UIDENT. - -* In instruction EXTEND, ability to omit "-> action", default is "-> ()" - -* Ability to add antiquotation (between $'s) as symbol rule, of type string, - interpreted as a keyword, in instruction EXTEND. - -* Ability to put entries with qualified names (Foo.bar) in instruction EXTEND. - ---- Quotations - -* The module Ast has been renamed MLast. The quotation expander "q_ast.cmo" - has been renamed "q_MLast.cmo". - -* Quotation expanders are now of two kinds: - - The "classical" type for expanders returning a string. These expanders - have now a supplementary parameter: a boolean value set to "True" - when the quotation is in a context of an expression an to "False" - when the quotation is in a context of a pattern. These expanders, - returning strings which are parsed afterwards, may work for some - language syntax and/or language extensions used (e.g. may work for - Righteous syntax and not for OCaml syntax). - - A new type of expander returning directly syntax trees. A pair - of functions, for expressions and for patterns must be provided. - These expanders are independant from the language syntax and/or - extensions used. - -* The predefined quotation expanders "ctyp_", "patt_" and "expr_" has - been deleted; one can use "ctyp", "patt", and "expr" in position of - pattern or expression. - ---- OCaml and Righteous syntaxes - -* Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo" - -* Corrected behavior different from OCaml's: "^" and "@" were at the same - level than "=": now, like OCaml, they have a separated right associative - level. - ---- Grammars behavior - -* While extending entries: default position is now "extension of the - first level", instead of "adding a new level at the end". - -* Another Change: in each precedence level, terminals are inserted before - other symbols (non terminals, lists, options, etc), LIDENT "foo" before - LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not - factorizable are now inserted before the other rules. - -* Changed algorithm of entries parsing: each precedence level is tested - against the stream *before* its next precedences levels (instead of - *after*): - EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END; - Now, parsing the entry e with the string "a" returns "xxx" instead of "a" - -* Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be - used now as normal identifiers. - -* When inserting a new rule, a warning appears if a rule with the - same production already existed (it is deleted). - -* Parse error messages (Gstream.Error) are formatted => spaces trigger - Format.print_space and newlines trigger Format.force_newline. - - -Camlp4 Version 0.5: -------------------- - -* Possible creation of native code library (make opt) - -* OCaml and Righteous Syntax more complete - -* Added pa_ru.cmo for compiling sequences of type unit (Righteous) - -* Quotations AST - - No more quotation long_id - - Antiquotations for identifiers more simple - -* Lot of small changes - - -Camlp4 Version 0.4: -------------------- - -* First distributed version diff --git a/camlp4/Camlp4.mlpack b/camlp4/Camlp4.mlpack deleted file mode 100644 index cc38b119..00000000 --- a/camlp4/Camlp4.mlpack +++ /dev/null @@ -1,9 +0,0 @@ -Debug -ErrorHandler -OCamlInitSyntax -Options -PreCast -Printers -Register -Sig -Struct diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml deleted file mode 100644 index 22874373..00000000 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ /dev/null @@ -1,412 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - - type loc = Loc.t - and meta_bool = - [ BTrue - | BFalse - | BAnt of string ] - and rec_flag = - [ ReRecursive - | ReNil - | ReAnt of string ] - and direction_flag = - [ DiTo - | DiDownto - | DiAnt of string ] - and mutable_flag = - [ MuMutable - | MuNil - | MuAnt of string ] - and private_flag = - [ PrPrivate - | PrNil - | PrAnt of string ] - and virtual_flag = - [ ViVirtual - | ViNil - | ViAnt of string ] - and override_flag = - [ OvOverride - | OvNil - | OvAnt of string ] - and row_var_flag = - [ RvRowVar - | RvNil - | RvAnt of string ] - and meta_option 'a = - [ ONone - | OSome of 'a - | OAnt of string ] - and meta_list 'a = - [ LNil - | LCons of 'a and meta_list 'a - | LAnt of string ] - and ident = - [ IdAcc of loc and ident and ident (* i . i *) - | IdApp of loc and ident and ident (* i i *) - | IdLid of loc and string (* foo *) - | IdUid of loc and string (* Bar *) - | IdAnt of loc and string (* $s$ *) ] - and ctyp = - [ TyNil of loc - | TyAli of loc and ctyp and ctyp (* t as t *) (* list 'a as 'a *) - | TyAny of loc (* _ *) - | TyApp of loc and ctyp and ctyp (* t t *) (* list 'a *) - | TyArr of loc and ctyp and ctyp (* t -> t *) (* int -> string *) - | TyCls of loc and ident (* #i *) (* #point *) - | TyLab of loc and string and ctyp (* ~s:t *) - | TyId of loc and ident (* i *) (* Lazy.t *) - | TyMan of loc and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *) - (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - | TyDcl of loc and string and list ctyp and ctyp and list (ctyp * ctyp) - (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) - | TyObj of loc and ctyp and row_var_flag - | TyOlb of loc and string and ctyp (* ?s:t *) - | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) - | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *) - | TyQuo of loc and string (* 's *) - | TyQuP of loc and string (* +'s *) - | TyQuM of loc and string (* -'s *) - | TyAnP of loc (* +_ *) - | TyAnM of loc (* -_ *) - | TyVrn of loc and string (* `s *) - | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) - | TyCol of loc and ctyp and ctyp (* t : t *) - | TySem of loc and ctyp and ctyp (* t; t *) - | TyCom of loc and ctyp and ctyp (* t, t *) - | TySum of loc and ctyp (* [ t ] *) (* [ A of int and string | B ] *) - | TyOf of loc and ctyp and ctyp (* t of t *) (* A of int *) - | TyAnd of loc and ctyp and ctyp (* t and t *) - | TyOr of loc and ctyp and ctyp (* t | t *) - | TyPrv of loc and ctyp (* private t *) - | TyMut of loc and ctyp (* mutable t *) - | TyTup of loc and ctyp (* ( t ) *) (* (int * string) *) - | TySta of loc and ctyp and ctyp (* t * t *) - | TyVrnEq of loc and ctyp (* [ = t ] *) - | TyVrnSup of loc and ctyp (* [ > t ] *) - | TyVrnInf of loc and ctyp (* [ < t ] *) - | TyVrnInfSup of loc and ctyp and ctyp (* [ < t > t ] *) - | TyAmp of loc and ctyp and ctyp (* t & t *) - | TyOfAmp of loc and ctyp and ctyp (* t of & t *) - | TyPkg of loc and module_type (* (module S) *) - | TyAnt of loc and string (* $s$ *) - ] - and patt = - [ PaNil of loc - | PaId of loc and ident (* i *) - | PaAli of loc and patt and patt (* p as p *) (* (Node x y as n) *) - | PaAnt of loc and string (* $s$ *) - | PaAny of loc (* _ *) - | PaApp of loc and patt and patt (* p p *) (* fun x y -> *) - | PaArr of loc and patt (* [| p |] *) - | PaCom of loc and patt and patt (* p, p *) - | PaSem of loc and patt and patt (* p; p *) - | PaChr of loc and string (* c *) (* 'x' *) - | PaInt of loc and string - | PaInt32 of loc and string - | PaInt64 of loc and string - | PaNativeInt of loc and string - | PaFlo of loc and string - | PaLab of loc and string and patt (* ~s or ~s:(p) *) - (* ?s or ?s:(p) *) - | PaOlb of loc and string and patt - (* ?s:(p = e) or ?(p = e) *) - | PaOlbi of loc and string and patt and expr - | PaOrp of loc and patt and patt (* p | p *) - | PaRng of loc and patt and patt (* p .. p *) - | PaRec of loc and patt (* { p } *) - | PaEq of loc and ident and patt (* i = p *) - | PaStr of loc and string (* s *) - | PaTup of loc and patt (* ( p ) *) - | PaTyc of loc and patt and ctyp (* (p : t) *) - | PaTyp of loc and ident (* #i *) - | PaVrn of loc and string (* `s *) - | PaLaz of loc and patt (* lazy p *) - | PaMod of loc and string (* (module M) *) ] - and expr = - [ ExNil of loc - | ExId of loc and ident (* i *) - | ExAcc of loc and expr and expr (* e.e *) - | ExAnt of loc and string (* $s$ *) - | ExApp of loc and expr and expr (* e e *) - | ExAre of loc and expr and expr (* e.(e) *) - | ExArr of loc and expr (* [| e |] *) - | ExSem of loc and expr and expr (* e; e *) - | ExAsf of loc (* assert False *) - | ExAsr of loc and expr (* assert e *) - | ExAss of loc and expr and expr (* e := e *) - | ExChr of loc and string (* 'c' *) - | ExCoe of loc and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) - | ExFlo of loc and string (* 3.14 *) - (* for s = e to/downto e do { e } *) - | ExFor of loc and string and expr and expr and direction_flag and expr - | ExFun of loc and match_case (* fun [ mc ] *) - | ExIfe of loc and expr and expr and expr (* if e then e else e *) - | ExInt of loc and string (* 42 *) - | ExInt32 of loc and string - | ExInt64 of loc and string - | ExNativeInt of loc and string - | ExLab of loc and string and expr (* ~s or ~s:e *) - | ExLaz of loc and expr (* lazy e *) - (* let b in e or let rec b in e *) - | ExLet of loc and rec_flag and binding and expr - (* let module s = me in e *) - | ExLmd of loc and string and module_expr and expr - (* match e with [ mc ] *) - | ExMat of loc and expr and match_case - (* new i *) - | ExNew of loc and ident - (* object ((p))? (cst)? end *) - | ExObj of loc and patt and class_str_item - (* ?s or ?s:e *) - | ExOlb of loc and string and expr - (* {< rb >} *) - | ExOvr of loc and rec_binding - (* { rb } or { (e) with rb } *) - | ExRec of loc and rec_binding and expr - (* do { e } *) - | ExSeq of loc and expr - (* e#s *) - | ExSnd of loc and expr and string - (* e.[e] *) - | ExSte of loc and expr and expr - (* s *) (* "foo" *) - | ExStr of loc and string - (* try e with [ mc ] *) - | ExTry of loc and expr and match_case - (* (e) *) - | ExTup of loc and expr - (* e, e *) - | ExCom of loc and expr and expr - (* (e : t) *) - | ExTyc of loc and expr and ctyp - (* `s *) - | ExVrn of loc and string - (* while e do { e } *) - | ExWhi of loc and expr and expr - (* let open i in e *) - | ExOpI of loc and ident and expr - (* fun (type t) -> e *) - (* let f x (type t) y z = e *) - | ExFUN of loc and string and expr - (* (module ME : S) which is represented as (module (ME : S)) *) - | ExPkg of loc and module_expr ] - and module_type = - [ MtNil of loc - (* i *) (* A.B.C *) - | MtId of loc and ident - (* functor (s : mt) -> mt *) - | MtFun of loc and string and module_type and module_type - (* 's *) - | MtQuo of loc and string - (* sig sg end *) - | MtSig of loc and sig_item - (* mt with wc *) - | MtWit of loc and module_type and with_constr - (* module type of m *) - | MtOf of loc and module_expr - | MtAnt of loc and string (* $s$ *) ] - and sig_item = - [ SgNil of loc - (* class cict *) - | SgCls of loc and class_type - (* class type cict *) - | SgClt of loc and class_type - (* sg ; sg *) - | SgSem of loc and sig_item and sig_item - (* # s or # s e *) - | SgDir of loc and string and expr - (* exception t *) - | SgExc of loc and ctyp - (* external s : t = s ... s *) - | SgExt of loc and string and ctyp and meta_list string - (* include mt *) - | SgInc of loc and module_type - (* module s : mt *) - | SgMod of loc and string and module_type - (* module rec mb *) - | SgRecMod of loc and module_binding - (* module type s = mt *) - | SgMty of loc and string and module_type - (* open i *) - | SgOpn of loc and ident - (* type t *) - | SgTyp of loc and ctyp - (* value s : t *) - | SgVal of loc and string and ctyp - | SgAnt of loc and string (* $s$ *) ] - and with_constr = - [ WcNil of loc - (* type t = t *) - | WcTyp of loc and ctyp and ctyp - (* module i = i *) - | WcMod of loc and ident and ident - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - (* wc and wc *) - | WcAnd of loc and with_constr and with_constr - | WcAnt of loc and string (* $s$ *) ] - and binding = - [ BiNil of loc - (* bi and bi *) (* let a = 42 and c = 43 *) - | BiAnd of loc and binding and binding - (* p = e *) (* let patt = expr *) - | BiEq of loc and patt and expr - | BiAnt of loc and string (* $s$ *) ] - and rec_binding = - [ RbNil of loc - (* rb ; rb *) - | RbSem of loc and rec_binding and rec_binding - (* i = e *) - | RbEq of loc and ident and expr - | RbAnt of loc and string (* $s$ *) ] - and module_binding = - [ MbNil of loc - (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) - | MbAnd of loc and module_binding and module_binding - (* s : mt = me *) - | MbColEq of loc and string and module_type and module_expr - (* s : mt *) - | MbCol of loc and string and module_type - | MbAnt of loc and string (* $s$ *) ] - and match_case = - [ McNil of loc - (* a | a *) - | McOr of loc and match_case and match_case - (* p (when e)? -> e *) - | McArr of loc and patt and expr and expr - | McAnt of loc and string (* $s$ *) ] - and module_expr = - [ MeNil of loc - (* i *) - | MeId of loc and ident - (* me me *) - | MeApp of loc and module_expr and module_expr - (* functor (s : mt) -> me *) - | MeFun of loc and string and module_type and module_expr - (* struct st end *) - | MeStr of loc and str_item - (* (me : mt) *) - | MeTyc of loc and module_expr and module_type - (* (value e) *) - (* (value e : S) which is represented as (value (e : S)) *) - | MePkg of loc and expr - | MeAnt of loc and string (* $s$ *) ] - and str_item = - [ StNil of loc - (* class cice *) - | StCls of loc and class_expr - (* class type cict *) - | StClt of loc and class_type - (* st ; st *) - | StSem of loc and str_item and str_item - (* # s or # s e *) - | StDir of loc and string and expr - (* exception t or exception t = i *) - | StExc of loc and ctyp and meta_option(*FIXME*) ident - (* e *) - | StExp of loc and expr - (* external s : t = s ... s *) - | StExt of loc and string and ctyp and meta_list string - (* include me *) - | StInc of loc and module_expr - (* module s = me *) - | StMod of loc and string and module_expr - (* module rec mb *) - | StRecMod of loc and module_binding - (* module type s = mt *) - | StMty of loc and string and module_type - (* open i *) - | StOpn of loc and ident - (* type t *) - | StTyp of loc and ctyp - (* value (rec)? bi *) - | StVal of loc and rec_flag and binding - | StAnt of loc and string (* $s$ *) ] - and class_type = - [ CtNil of loc - (* (virtual)? i ([ t ])? *) - | CtCon of loc and virtual_flag and ident and ctyp - (* [t] -> ct *) - | CtFun of loc and ctyp and class_type - (* object ((t))? (csg)? end *) - | CtSig of loc and ctyp and class_sig_item - (* ct and ct *) - | CtAnd of loc and class_type and class_type - (* ct : ct *) - | CtCol of loc and class_type and class_type - (* ct = ct *) - | CtEq of loc and class_type and class_type - (* $s$ *) - | CtAnt of loc and string ] - and class_sig_item = - [ CgNil of loc - (* type t = t *) - | CgCtr of loc and ctyp and ctyp - (* csg ; csg *) - | CgSem of loc and class_sig_item and class_sig_item - (* inherit ct *) - | CgInh of loc and class_type - (* method s : t or method private s : t *) - | CgMth of loc and string and private_flag and ctyp - (* value (virtual)? (mutable)? s : t *) - | CgVal of loc and string and mutable_flag and virtual_flag and ctyp - (* method virtual (private)? s : t *) - | CgVir of loc and string and private_flag and ctyp - | CgAnt of loc and string (* $s$ *) ] - and class_expr = - [ CeNil of loc - (* ce e *) - | CeApp of loc and class_expr and expr - (* (virtual)? i ([ t ])? *) - | CeCon of loc and virtual_flag and ident and ctyp - (* fun p -> ce *) - | CeFun of loc and patt and class_expr - (* let (rec)? bi in ce *) - | CeLet of loc and rec_flag and binding and class_expr - (* object ((p))? (cst)? end *) - | CeStr of loc and patt and class_str_item - (* ce : ct *) - | CeTyc of loc and class_expr and class_type - (* ce and ce *) - | CeAnd of loc and class_expr and class_expr - (* ce = ce *) - | CeEq of loc and class_expr and class_expr - (* $s$ *) - | CeAnt of loc and string ] - and class_str_item = - [ CrNil of loc - (* cst ; cst *) - | CrSem of loc and class_str_item and class_str_item - (* type t = t *) - | CrCtr of loc and ctyp and ctyp - (* inherit(!)? ce (as s)? *) - | CrInh of loc and override_flag and class_expr and string - (* initializer e *) - | CrIni of loc and expr - (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) - | CrMth of loc and string and override_flag and private_flag and expr and ctyp - (* value(!)? (mutable)? s = e *) - | CrVal of loc and string and override_flag and mutable_flag and expr - (* method virtual (private)? s : t *) - | CrVir of loc and string and private_flag and ctyp - (* value virtual (mutable)? s : t *) - | CrVvr of loc and string and mutable_flag and ctyp - | CrAnt of loc and string (* $s$ *) ]; diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml deleted file mode 100644 index 73a38db8..00000000 --- a/camlp4/Camlp4/Debug.ml +++ /dev/null @@ -1,64 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -open Format; - -module Debug = struct value mode _ = False; end; - -type section = string; - -value out_channel = - try - let f = Sys.getenv "CAMLP4_DEBUG_FILE" in - open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] - 0o666 f - with - [ Not_found -> Pervasives.stderr ]; - -module StringSet = Set.Make String; - -value mode = - try - let str = Sys.getenv "CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' in - loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) - with - [ Not_found -> - StringSet.add (String.sub str i (String.length str - i)) acc ] in - let sections = loop StringSet.empty 0 in - if StringSet.mem "*" sections then fun _ -> True - else fun x -> StringSet.mem x sections - with [ Not_found -> fun _ -> False ]; - -value formatter = - let header = "camlp4-debug: " in - let at_bol = ref True in - (make_formatter - (fun buf pos len -> - for i = pos to pos + len - 1 do - if at_bol.val then output_string out_channel header else (); - let ch = buf.[i]; - output_char out_channel ch; - at_bol.val := ch = '\n'; - done) - (fun () -> flush out_channel)); - -value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section; diff --git a/camlp4/Camlp4/Debug.mli b/camlp4/Camlp4/Debug.mli deleted file mode 100644 index 97597f9c..00000000 --- a/camlp4/Camlp4/Debug.mli +++ /dev/null @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -type section = string; -value mode : section -> bool; -value printf : section -> format 'a Format.formatter unit -> 'a; diff --git a/camlp4/Camlp4/ErrorHandler.ml b/camlp4/Camlp4/ErrorHandler.ml deleted file mode 100644 index bfefa49a..00000000 --- a/camlp4/Camlp4/ErrorHandler.ml +++ /dev/null @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -module ObjTools = struct - - value desc obj = - if Obj.is_block obj then - "tag = " ^ string_of_int (Obj.tag obj) - else "int_val = " ^ string_of_int (Obj.obj obj); - - (*Imported from the extlib*) - value rec to_string r = - if Obj.is_int r then - let i = (Obj.magic r : int) - in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1) - else (* Block. *) - let rec get_fields acc = - fun - [ 0 -> acc - | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ] - in - let rec is_list r = - if Obj.is_int r then - r = Obj.repr 0 (* [] *) - else - let s = Obj.size r and t = Obj.tag r in - t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) - in - let rec get_list r = - if Obj.is_int r then [] - else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t] - in - let opaque name = - (* XXX In future, print the address of value 'r'. Not possible in - * pure OCaml at the moment. - *) - "<" ^ name ^ ">" - in - let s = Obj.size r and t = Obj.tag r in - (* From the tag, determine the type of block. *) - match t with - [ _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (List.map to_string fields) ^ "]" - | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" - | x when x = Obj.closure_tag -> - opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let (_class, id, slots) = - match fields with - [ [h; h'::t] -> (h, h', t) - | _ -> assert False ] - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")" - | x when x = Obj.infix_tag -> - opaque "infix" - | x when x = Obj.forward_tag -> - opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ - " (" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" - | x when x = Obj.double_tag -> - Camlp4_import.Oprint.float_repres (Obj.magic r : float) - | x when x = Obj.abstract_tag -> - opaque "abstract" - | x when x = Obj.custom_tag -> - opaque "custom" - | x when x = Obj.final_tag -> - opaque "final" - | _ -> - failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ]; - - value print ppf x = fprintf ppf "%s" (to_string x); - value print_desc ppf x = fprintf ppf "%s" (desc x); - -end; - -value default_handler ppf x = do { - let x = Obj.repr x; - fprintf ppf "Camlp4: Uncaught exception: %s" - (Obj.obj (Obj.field (Obj.field x 0) 0) : string); - if Obj.size x > 1 then do { - pp_print_string ppf " ("; - for i = 1 to Obj.size x - 1 do - if i > 1 then pp_print_string ppf ", " else (); - ObjTools.print ppf (Obj.field x i); - done; - pp_print_char ppf ')' - } - else (); - fprintf ppf "@." -}; - -value handler = ref (fun ppf default_handler exn -> default_handler ppf exn); - -value register f = - let current_handler = handler.val in - handler.val := - fun ppf default_handler exn -> - try f ppf exn with exn -> current_handler ppf default_handler exn; - -module Register (Error : Sig.Error) = struct - let current_handler = handler.val in - handler.val := - fun ppf default_handler -> - fun [ Error.E x -> Error.print ppf x - | x -> current_handler ppf default_handler x ]; -end; - - -value gen_print ppf default_handler = - fun - [ Out_of_memory -> fprintf ppf "Out of memory" - | Assert_failure (file, line, char) -> - fprintf ppf "Assertion failed, file %S, line %d, char %d" - file line char - | Match_failure (file, line, char) -> - fprintf ppf "Pattern matching failed, file %S, line %d, char %d" - file line char - | Failure str -> fprintf ppf "Failure: %S" str - | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str - | Sys_error str -> fprintf ppf "I/O error: %S" str - | Stream.Failure -> fprintf ppf "Parse failure" - | Stream.Error str -> fprintf ppf "Parse error: %s" str - | x -> handler.val ppf default_handler x ]; - -value print ppf = gen_print ppf default_handler; - -value try_print ppf = gen_print ppf (fun _ -> raise); - -value to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" print exn in - Buffer.contents buf; - -value try_to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" try_print exn in - Buffer.contents buf; diff --git a/camlp4/Camlp4/ErrorHandler.mli b/camlp4/Camlp4/ErrorHandler.mli deleted file mode 100644 index d73238df..00000000 --- a/camlp4/Camlp4/ErrorHandler.mli +++ /dev/null @@ -1,36 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) -value print : Format.formatter -> exn -> unit; - -value try_print : Format.formatter -> exn -> unit; - -value to_string : exn -> string; - -value try_to_string : exn -> string; - -value register : (Format.formatter -> exn -> unit) -> unit; - -module Register (Error : Sig.Error) : sig end; - -module ObjTools : sig - value print : Format.formatter -> Obj.t -> unit; - value print_desc : Format.formatter -> Obj.t -> unit; - (*Imported from the extlib*) - value to_string : Obj.t -> string; - value desc : Obj.t -> string; -end; diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml deleted file mode 100644 index c424bfa7..00000000 --- a/camlp4/Camlp4/OCamlInitSyntax.ml +++ /dev/null @@ -1,265 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) - (Gram : Sig.Grammar.Static with module Loc = Ast.Loc - with type Token.t = Sig.camlp4_token) - (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast) -: Sig.Camlp4Syntax with module Loc = Ast.Loc - and module Ast = Ast - and module Token = Gram.Token - and module Gram = Gram - and module Quotation = Quotation -= struct - - module Loc = Ast.Loc; - module Ast = Ast; - module Gram = Gram; - module Token = Gram.Token; - open Sig; - - (* Warnings *) - type warning = Loc.t -> string -> unit; - value default_warning loc txt = Format.eprintf " %a: %s@." Loc.print loc txt; - value current_warning = ref default_warning; - value print_warning loc txt = current_warning.val loc txt; - - value a_CHAR = Gram.Entry.mk "a_CHAR"; - value a_FLOAT = Gram.Entry.mk "a_FLOAT"; - value a_INT = Gram.Entry.mk "a_INT"; - value a_INT32 = Gram.Entry.mk "a_INT32"; - value a_INT64 = Gram.Entry.mk "a_INT64"; - value a_LABEL = Gram.Entry.mk "a_LABEL"; - value a_LIDENT = Gram.Entry.mk "a_LIDENT"; - value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT"; - value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL"; - value a_STRING = Gram.Entry.mk "a_STRING"; - value a_UIDENT = Gram.Entry.mk "a_UIDENT"; - value a_ident = Gram.Entry.mk "a_ident"; - value amp_ctyp = Gram.Entry.mk "amp_ctyp"; - value and_ctyp = Gram.Entry.mk "and_ctyp"; - value match_case = Gram.Entry.mk "match_case"; - value match_case0 = Gram.Entry.mk "match_case0"; - value binding = Gram.Entry.mk "binding"; - value class_declaration = Gram.Entry.mk "class_declaration"; - value class_description = Gram.Entry.mk "class_description"; - value class_expr = Gram.Entry.mk "class_expr"; - value class_fun_binding = Gram.Entry.mk "class_fun_binding"; - value class_fun_def = Gram.Entry.mk "class_fun_def"; - value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr"; - value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type"; - value class_longident = Gram.Entry.mk "class_longident"; - value class_longident_and_param = Gram.Entry.mk "class_longident_and_param"; - value class_name_and_param = Gram.Entry.mk "class_name_and_param"; - value class_sig_item = Gram.Entry.mk "class_sig_item"; - value class_signature = Gram.Entry.mk "class_signature"; - value class_str_item = Gram.Entry.mk "class_str_item"; - value class_structure = Gram.Entry.mk "class_structure"; - value class_type = Gram.Entry.mk "class_type"; - value class_type_declaration = Gram.Entry.mk "class_type_declaration"; - value class_type_longident = Gram.Entry.mk "class_type_longident"; - value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param"; - value class_type_plus = Gram.Entry.mk "class_type_plus"; - value comma_ctyp = Gram.Entry.mk "comma_ctyp"; - value comma_expr = Gram.Entry.mk "comma_expr"; - value comma_ipatt = Gram.Entry.mk "comma_ipatt"; - value comma_patt = Gram.Entry.mk "comma_patt"; - value comma_type_parameter = Gram.Entry.mk "comma_type_parameter"; - value constrain = Gram.Entry.mk "constrain"; - value constructor_arg_list = Gram.Entry.mk "constructor_arg_list"; - value constructor_declaration = Gram.Entry.mk "constructor_declaration"; - value constructor_declarations = Gram.Entry.mk "constructor_declarations"; - value ctyp = Gram.Entry.mk "ctyp"; - value cvalue_binding = Gram.Entry.mk "cvalue_binding"; - value direction_flag = Gram.Entry.mk "direction_flag"; - value direction_flag_quot = Gram.Entry.mk "direction_flag_quot"; - value dummy = Gram.Entry.mk "dummy"; - value entry_eoi = Gram.Entry.mk "entry_eoi"; - value eq_expr = Gram.Entry.mk "eq_expr"; - value expr = Gram.Entry.mk "expr"; - value expr_eoi = Gram.Entry.mk "expr_eoi"; - value field_expr = Gram.Entry.mk "field_expr"; - value field_expr_list = Gram.Entry.mk "field_expr_list"; - value fun_binding = Gram.Entry.mk "fun_binding"; - value fun_def = Gram.Entry.mk "fun_def"; - value ident = Gram.Entry.mk "ident"; - value implem = Gram.Entry.mk "implem"; - value interf = Gram.Entry.mk "interf"; - value ipatt = Gram.Entry.mk "ipatt"; - value ipatt_tcon = Gram.Entry.mk "ipatt_tcon"; - value label = Gram.Entry.mk "label"; - value label_declaration = Gram.Entry.mk "label_declaration"; - value label_declaration_list = Gram.Entry.mk "label_declaration_list"; - value label_expr = Gram.Entry.mk "label_expr"; - value label_expr_list = Gram.Entry.mk "label_expr_list"; - value label_ipatt = Gram.Entry.mk "label_ipatt"; - value label_ipatt_list = Gram.Entry.mk "label_ipatt_list"; - value label_longident = Gram.Entry.mk "label_longident"; - value label_patt = Gram.Entry.mk "label_patt"; - value label_patt_list = Gram.Entry.mk "label_patt_list"; - value labeled_ipatt = Gram.Entry.mk "labeled_ipatt"; - value let_binding = Gram.Entry.mk "let_binding"; - value meth_list = Gram.Entry.mk "meth_list"; - value meth_decl = Gram.Entry.mk "meth_decl"; - value module_binding = Gram.Entry.mk "module_binding"; - value module_binding0 = Gram.Entry.mk "module_binding0"; - value module_declaration = Gram.Entry.mk "module_declaration"; - value module_expr = Gram.Entry.mk "module_expr"; - value module_longident = Gram.Entry.mk "module_longident"; - value module_longident_with_app = Gram.Entry.mk "module_longident_with_app"; - value module_rec_declaration = Gram.Entry.mk "module_rec_declaration"; - value module_type = Gram.Entry.mk "module_type"; - value package_type = Gram.Entry.mk "package_type"; - value more_ctyp = Gram.Entry.mk "more_ctyp"; - value name_tags = Gram.Entry.mk "name_tags"; - value opt_as_lident = Gram.Entry.mk "opt_as_lident"; - value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt"; - value opt_class_self_type = Gram.Entry.mk "opt_class_self_type"; - value opt_class_signature = Gram.Entry.mk "opt_class_signature"; - value opt_class_structure = Gram.Entry.mk "opt_class_structure"; - value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp"; - value opt_dot_dot = Gram.Entry.mk "opt_dot_dot"; - value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot"; - value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp"; - value opt_expr = Gram.Entry.mk "opt_expr"; - value opt_meth_list = Gram.Entry.mk "opt_meth_list"; - value opt_mutable = Gram.Entry.mk "opt_mutable"; - value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot"; - value opt_polyt = Gram.Entry.mk "opt_polyt"; - value opt_private = Gram.Entry.mk "opt_private"; - value private_flag_quot = Gram.Entry.mk "private_flag_quot"; - value opt_rec = Gram.Entry.mk "opt_rec"; - value rec_flag_quot = Gram.Entry.mk "rec_flag_quot"; - value opt_sig_items = Gram.Entry.mk "opt_sig_items"; - value opt_str_items = Gram.Entry.mk "opt_str_items"; - value opt_virtual = Gram.Entry.mk "opt_virtual"; - value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot"; - value opt_override = Gram.Entry.mk "opt_override"; - value override_flag_quot = Gram.Entry.mk "override_flag_quot"; - value opt_when_expr = Gram.Entry.mk "opt_when_expr"; - value patt = Gram.Entry.mk "patt"; - value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt"; - value patt_eoi = Gram.Entry.mk "patt_eoi"; - value patt_tcon = Gram.Entry.mk "patt_tcon"; - value phrase = Gram.Entry.mk "phrase"; - value poly_type = Gram.Entry.mk "poly_type"; - value row_field = Gram.Entry.mk "row_field"; - value sem_expr = Gram.Entry.mk "sem_expr"; - value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list"; - value sem_patt = Gram.Entry.mk "sem_patt"; - value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list"; - value semi = Gram.Entry.mk "semi"; - value sequence = Gram.Entry.mk "sequence"; - value do_sequence = Gram.Entry.mk "do_sequence"; - value sig_item = Gram.Entry.mk "sig_item"; - value sig_items = Gram.Entry.mk "sig_items"; - value star_ctyp = Gram.Entry.mk "star_ctyp"; - value str_item = Gram.Entry.mk "str_item"; - value str_items = Gram.Entry.mk "str_items"; - value top_phrase = Gram.Entry.mk "top_phrase"; - value type_constraint = Gram.Entry.mk "type_constraint"; - value type_declaration = Gram.Entry.mk "type_declaration"; - value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters"; - value type_kind = Gram.Entry.mk "type_kind"; - value type_longident = Gram.Entry.mk "type_longident"; - value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters"; - value type_parameter = Gram.Entry.mk "type_parameter"; - value type_parameters = Gram.Entry.mk "type_parameters"; - value typevars = Gram.Entry.mk "typevars"; - value use_file = Gram.Entry.mk "use_file"; - value val_longident = Gram.Entry.mk "val_longident"; - value value_let = Gram.Entry.mk "value_let"; - value value_val = Gram.Entry.mk "value_val"; - value with_constr = Gram.Entry.mk "with_constr"; - value expr_quot = Gram.Entry.mk "quotation of expression"; - value patt_quot = Gram.Entry.mk "quotation of pattern"; - value ctyp_quot = Gram.Entry.mk "quotation of type"; - value str_item_quot = Gram.Entry.mk "quotation of structure item"; - value sig_item_quot = Gram.Entry.mk "quotation of signature item"; - value class_str_item_quot = Gram.Entry.mk "quotation of class structure item"; - value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item"; - value module_expr_quot = Gram.Entry.mk "quotation of module expression"; - value module_type_quot = Gram.Entry.mk "quotation of module type"; - value class_type_quot = Gram.Entry.mk "quotation of class type"; - value class_expr_quot = Gram.Entry.mk "quotation of class expression"; - value with_constr_quot = Gram.Entry.mk "quotation of with constraint"; - value binding_quot = Gram.Entry.mk "quotation of binding"; - value rec_binding_quot = Gram.Entry.mk "quotation of record binding"; - value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)"; - value module_binding_quot = Gram.Entry.mk "quotation of module rec binding"; - value ident_quot = Gram.Entry.mk "quotation of identifier"; - value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')"; - value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)"; - value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')"; - value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')"; - value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')"; - value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)"; - - EXTEND Gram - top_phrase: - [ [ `EOI -> None ] ] - ; - END; - - module AntiquotSyntax = struct - module Loc = Ast.Loc; - module Ast = Sig.Camlp4AstToAst Ast; - module Gram = Gram; - value antiquot_expr = Gram.Entry.mk "antiquot_expr"; - value antiquot_patt = Gram.Entry.mk "antiquot_patt"; - EXTEND Gram - antiquot_expr: - [ [ x = expr; `EOI -> x ] ] - ; - antiquot_patt: - [ [ x = patt; `EOI -> x ] ] - ; - END; - value parse_expr loc str = Gram.parse_string antiquot_expr loc str; - value parse_patt loc str = Gram.parse_string antiquot_patt loc str; - end; - - module Quotation = Quotation; - - value wrap directive_handler pa init_loc cs = - let rec loop loc = - let (pl, stopped_at_directive) = pa loc cs in - match stopped_at_directive with - [ Some new_loc -> - let pl = - match List.rev pl with - [ [] -> assert False - | [x :: xs] -> - match directive_handler x with - [ None -> xs - | Some x -> [x :: xs] ] ] - in (List.rev pl) @ (loop new_loc) - | None -> pl ] - in loop init_loc; - - value parse_implem ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse implem) _loc cs in - <:str_item< $list:l$ >>; - - value parse_interf ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse interf) _loc cs in - <:sig_item< $list:l$ >>; - - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff --git a/camlp4/Camlp4/Options.ml b/camlp4/Camlp4/Options.ml deleted file mode 100644 index 20503b40..00000000 --- a/camlp4/Camlp4/Options.ml +++ /dev/null @@ -1,191 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type spec_list = list (string * Arg.spec * string); -open Format; - -value rec action_arg s sl = - fun - [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None - | Arg.Bool f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | [] -> None ] - else - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None - | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None - | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] } - | Arg.String f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f s; Some sl } - | [] -> None ] - else do { f s; Some sl } - | Arg.Set_string r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := s; Some sl } - | [] -> None ] - else do { r.val := s; Some sl } - | Arg.Int f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Set_int r -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Float f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f (float_of_string s); Some sl } - | [] -> None ] - else do { f (float_of_string s); Some sl } - | Arg.Set_float r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := (float_of_string s); Some sl } - | [] -> None ] - else do { r.val := (float_of_string s); Some sl } - | Arg.Tuple specs -> - let rec action_args s sl = - fun - [ [] -> Some sl - | [spec :: spec_list] -> - match action_arg s sl spec with - [ None -> action_args "" [] spec_list - | Some [s :: sl] -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list - ] - ] in - action_args s sl specs - | Arg.Symbol syms f -> - match (if s = "" then sl else [s :: sl]) with - [ [s :: sl] when List.mem s syms -> do { f s; Some sl } - | _ -> None ] - ]; - -value common_start s1 s2 = - loop 0 where rec loop i = - if i == String.length s1 || i == String.length s2 then i - else if s1.[i] == s2.[i] then loop (i + 1) - else i; - -value parse_arg fold s sl = - fold - (fun (name, action, _) acu -> - let i = common_start s name in - if i == String.length name then - try action_arg (String.sub s i (String.length s - i)) sl action with - [ Arg.Bad _ -> acu ] - else acu) None; - -value rec parse_aux fold anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg fold s sl with - [ Some sl -> parse_aux fold anon_fun sl - | None -> [s :: parse_aux fold anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ]; - -value align_doc key s = - let s = - loop 0 where rec loop i = - if i = String.length s then "" - else if s.[i] = ' ' then loop (i + 1) - else String.sub s i (String.length s - i) - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - loop 0 where rec loop i = - if i = String.length s then ("", s) - else if s.[i] <> '>' then loop (i + 1) - else - let p = String.sub s 0 (i + 1) in - loop (i + 1) where rec loop i = - if i >= String.length s then (p, "") - else if s.[i] = ' ' then loop (i + 1) - else (p, String.sub s i (String.length s - i)) - else ("", s) - else ("", "") - in - let tab = - String.make (max 1 (16 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s; - -value make_symlist l = - match l with - [ [] -> "" - | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]; - -value print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - [ Arg.Symbol symbs _ -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) - l; - -value remaining_args argv = - let rec loop l i = - if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)); - -value init_spec_list = ref []; -value ext_spec_list = ref []; - -value init spec_list = init_spec_list.val := spec_list; - -value add name spec descr = - ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val]; - -value fold f init = - let spec_list = init_spec_list.val @ ext_spec_list.val in - let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in - List.fold_right f specs init; - -value parse anon_fun argv = - let remaining_args = remaining_args argv in - parse_aux fold anon_fun remaining_args; - -value ext_spec_list () = ext_spec_list.val; diff --git a/camlp4/Camlp4/Options.mli b/camlp4/Camlp4/Options.mli deleted file mode 100644 index 2deb878d..00000000 --- a/camlp4/Camlp4/Options.mli +++ /dev/null @@ -1,26 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type spec_list = list (string * Arg.spec * string); -value init : spec_list -> unit; -value add : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value print_usage_list : spec_list -> unit; -value ext_spec_list : unit -> spec_list; -value parse : (string -> unit) -> array string -> list string; diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml deleted file mode 100644 index 16974851..00000000 --- a/camlp4/Camlp4/PreCast.ml +++ /dev/null @@ -1,67 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.PreCast"; - value version = Sys.ocaml_version; -end; - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Loc = Struct.Loc; -module Ast = Struct.Camlp4Ast.Make Loc; -module Token = Struct.Token.Make Loc; -module Lexer = Struct.Lexer.Make Token; -module Gram = Struct.Grammar.Static.Make Lexer; -module DynLoader = Struct.DynLoader; -module Quotation = Struct.Quotation.Make Ast; -module MakeSyntax (U : sig end) = OCamlInitSyntax.Make Ast Gram Quotation; -module Syntax = MakeSyntax (struct end); -module AstFilters = Struct.AstFilters.Make Ast; -module MakeGram = Struct.Grammar.Static.Make; - -module Printers = struct - module OCaml = Printers.OCaml.Make Syntax; - module OCamlr = Printers.OCamlr.Make Syntax; - (* module OCamlrr = Printers.OCamlrr.Make Syntax; *) - module DumpOCamlAst = Printers.DumpOCamlAst.Make Syntax; - module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax; - module Null = Printers.Null.Make Syntax; -end; diff --git a/camlp4/Camlp4/PreCast.mli b/camlp4/Camlp4/PreCast.mli deleted file mode 100644 index a7dad534..00000000 --- a/camlp4/Camlp4/PreCast.mli +++ /dev/null @@ -1,76 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Id : Sig.Id; -module Loc : Sig.Loc; -module Ast : Sig.Camlp4Ast with module Loc = Loc; -module Token : Sig.Token - with module Loc = Loc - and type t = camlp4_token; -module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; -module Gram : Sig.Grammar.Static - with module Loc = Loc - and module Token = Token; -module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast; -module DynLoader : Sig.DynLoader; -module AstFilters : Sig.AstFilters with module Ast = Ast; -module Syntax : Sig.Camlp4Syntax - with module Loc = Loc - and module Token = Token - and module Ast = Ast - and module Gram = Gram - and module Quotation = Quotation; - -module Printers : sig - module OCaml : (Sig.Printer Ast).S; - module OCamlr : (Sig.Printer Ast).S; - module DumpOCamlAst : (Sig.Printer Ast).S; - module DumpCamlp4Ast : (Sig.Printer Ast).S; - module Null : (Sig.Printer Ast).S; -end; - -module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) - : Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token; - -module MakeSyntax (U : sig end) : Sig.Syntax; diff --git a/camlp4/Camlp4/Printers.mlpack b/camlp4/Camlp4/Printers.mlpack deleted file mode 100644 index 9e593a75..00000000 --- a/camlp4/Camlp4/Printers.mlpack +++ /dev/null @@ -1,5 +0,0 @@ -DumpCamlp4Ast -DumpOCamlAst -Null -OCaml -OCamlr diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml deleted file mode 100644 index 5b34e994..00000000 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml +++ /dev/null @@ -1,51 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4Printers.DumpCamlp4Ast"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - - value with_open_out_file x f = - match x with - [ Some file -> do { let oc = open_out_bin file; - f oc; - flush oc; - close_out oc } - | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; - - value dump_ast magic ast oc = do { - output_string oc magic; - output_value oc ast; - }; - - value print_interf ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast); - - value print_implem ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast); - -end; diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli deleted file mode 100644 index 5a0eb96f..00000000 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli +++ /dev/null @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml deleted file mode 100644 index 57d2a15e..00000000 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.ml +++ /dev/null @@ -1,53 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id = struct - value name = "Camlp4Printers.DumpOCamlAst"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make Ast; - - value with_open_out_file x f = - match x with - [ Some file -> do { let oc = open_out_bin file; - f oc; - flush oc; - close_out oc } - | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; - - value dump_pt magic fname pt oc = do { - output_string oc magic; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - }; - - value print_interf ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.sig_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt); - - value print_implem ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.str_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt); - -end; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.mli b/camlp4/Camlp4/Printers/DumpOCamlAst.mli deleted file mode 100644 index 16eafbdb..00000000 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.mli +++ /dev/null @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml deleted file mode 100644 index 3b3b9549..00000000 --- a/camlp4/Camlp4/Printers/Null.ml +++ /dev/null @@ -1,30 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.Printers.Null"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) = struct - include Syntax; - - value print_interf ?input_file:(_) ?output_file:(_) _ = (); - value print_implem ?input_file:(_) ?output_file:(_) _ = (); -end; diff --git a/camlp4/Camlp4/Printers/Null.mli b/camlp4/Camlp4/Printers/Null.mli deleted file mode 100644 index f81ce613..00000000 --- a/camlp4/Camlp4/Printers/Null.mli +++ /dev/null @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml deleted file mode 100644 index 338655f0..00000000 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ /dev/null @@ -1,1156 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCaml"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value pp = fprintf; - value cut f = fprintf f "@ "; - - value list' elt sep sep' f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; pp f sep'; loop xs } ] in - fun - [ [] -> () - | [x] -> do { elt f x; pp f sep' } - | [x::xs] -> do { elt f x; pp f sep'; loop xs } ]; - - value list elt sep f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; loop xs } ] in - fun - [ [] -> () - | [x] -> elt f x - | [x::xs] -> do { elt f x; loop xs } ]; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value meta_list elt sep f mxs = - let xs = list_of_meta_list mxs in - list elt sep f xs; - - module CommentFilter = Struct.CommentFilter.Make Token; - value comment_filter = CommentFilter.mk (); - CommentFilter.define (Gram.get_filter ()) comment_filter; - - module StringSet = Set.Make String; - - value infix_lidents = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - - value is_infix = - let first_chars = ['='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\'] - and infixes = - List.fold_right StringSet.add infix_lidents StringSet.empty - in fun s -> (StringSet.mem s infixes - || (s <> "" && List.mem s.[0] first_chars)); - - value is_keyword = - let keywords = (* without infix_lidents *) - List.fold_right StringSet.add - ["and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; - "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; - "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; - "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "sig"; - "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; - "when"; "while"; "with"] StringSet.empty - in fun s -> StringSet.mem s keywords; - - module Lexer = Struct.Lexer.Make Token; - let module M = ErrorHandler.Register Lexer.Error in (); - open Sig; - value lexer s = - Lexer.from_string ~quotations:Camlp4_config.quotations.val Loc.ghost s; - value lex_string str = - try match lexer str with parser - [: `(tok, _); `(EOI, _) :] -> tok - with - [ Stream.Failure | Stream.Error _ -> - failwith (sprintf - "Cannot print %S this string contains more than one token" str) - | Lexer.Error.E exn -> - failwith (sprintf - "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" - str (Lexer.Error.to_string exn)) ]; - - (* This is to be sure character literals are always escaped. *) - value ocaml_char x = Char.escaped (Struct.Token.Eval.char x); - - value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_ctyp_args a al = - match a with - [ <:ctyp< $a1$ $a2$ >> -> get_ctyp_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value is_irrefut_patt = Ast.is_irrefut_patt; - - value rec expr_fun_args = - fun - [ <:expr< fun $p$ -> $e$ >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([`patt p :: pl], e) - else ([], ge) - | <:expr< fun (type $i$) -> $e$ >> -> - let (pl, e) = expr_fun_args e in - ([`newtype i :: pl], e) - | ge -> ([], ge) ]; - - value rec class_expr_fun_args = - fun - [ <:class_expr< fun $p$ -> $ce$ >> as ge -> - if is_irrefut_patt p then - let (pl, ce) = class_expr_fun_args ce in - ([p :: pl], ce) - else ([], ge) - | ge -> ([], ge) ]; - - value rec do_print_comments_before loc f = - parser - [ [: ` (comm, comm_loc) when Loc.strictly_before comm_loc loc; s :] -> - let () = f comm comm_loc in - do_print_comments_before loc f s - | [: :] -> () ]; - - class printer ?curry_constr:(init_curry_constr = False) ?(comments = True) () = - object (o) - - (** pipe means we are under a match case (try, function) *) - value pipe = False; - value semi = False; - - method under_pipe = {< pipe = True >}; - method under_semi = {< semi = True >}; - method reset_semi = {< semi = False >}; - method reset = {< pipe = False; semi = False >}; - - value semisep : sep = ";;"; - value no_semisep : sep = ""; (* used to mark where ";;" should not occur *) - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value var_conversion = False; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "val"; - method value_let = "let"; - - method semisep = semisep; - method set_semisep s = {< semisep = s >}; - method set_comments b = {< mode = if b then `comments else `no_comments >}; - method set_loc_and_comments = {< mode = `loc_and_comments >}; - method set_curry_constr b = {< curry_constr = b >}; - - method print_comments_before loc f = - match mode with - [ `comments -> - do_print_comments_before loc (fun c _ -> pp f "%s@ " c) - (CommentFilter.take_stream comment_filter) - | `loc_and_comments -> - let () = pp f "(*loc: %a*)@ " Loc.dump loc in - do_print_comments_before loc - (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) - (CommentFilter.take_stream comment_filter) - | _ -> () ]; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match (var_conversion, v) with - [ (True, "val") -> pp f "contents" - | (True, "True") -> pp f "true" - | (True, "False") -> pp f "false" - | _ -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s - | (LIDENT s | ESCAPED_IDENT s) when List.mem s infix_lidents -> - pp f "( %s )" s - | SYMBOL s -> - pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "%a@ " o#ctyp x - | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l ]; - - method class_params f = - fun - [ <:ctyp< $t1$, $t2$ >> -> - pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 - | x -> o#ctyp f x ]; - - method override_flag f = - fun - [ Ast.OvOverride -> pp f "!" - | Ast.OvNil -> () - | Ast.OvAnt s -> o#anti f s ]; - - method mutable_flag f = fun - [ Ast.MuMutable -> pp f "mutable@ " - | Ast.MuNil -> () - | Ast.MuAnt s -> o#anti f s ]; - - method rec_flag f = fun - [ Ast.ReRecursive -> pp f "rec@ " - | Ast.ReNil -> () - | Ast.ReAnt s -> o#anti f s ]; - - method virtual_flag f = fun - [ Ast.ViVirtual -> pp f "virtual@ " - | Ast.ViNil -> () - | Ast.ViAnt s -> o#anti f s ]; - - method private_flag f = fun - [ Ast.PrPrivate -> pp f "private@ " - | Ast.PrNil -> () - | Ast.PrAnt s -> o#anti f s ]; - - method anti f s = pp f "$%s$" s; - - method seq f = - fun - [ <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 - | <:expr< do { $e$ } >> -> - o#seq f e - | e -> o#expr f e ]; - - (* FIXME when the Format module will fixed. - pp_print_if_newline f (); - pp_print_string f "| "; *) - method match_case f = - fun - [ <:match_case@_loc<>> -> - pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc - | a -> o#match_case_aux f a ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method fun_binding f = - fun - [ `patt p -> o#simple_patt f p - | `newtype i -> pp f "(type %s)" i ]; - - method binding f bi = - let () = o#node f bi Ast.loc_of_binding in - match bi with - [ <:binding<>> -> () - | <:binding< $b1$ and $b2$ >> -> - do { o#binding f b1; pp f o#andsep; o#binding f b2 } - | <:binding< $p$ = $e$ >> -> - let (pl, e') = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] in - match (p, e') with - [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) -> - pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e' - | (<:patt< $lid:_$ >>, _) -> - pp f "%a @[<0>%a=@]@ %a" o#simple_patt - p (list' o#fun_binding "" "@ ") pl o#expr e' - | _ -> - pp f "%a =@ %a" o#simple_patt p o#expr e ] - | <:binding< $anti:s$ >> -> o#anti f s ]; - - method record_binding f bi = - let () = o#node f bi Ast.loc_of_rec_binding in - match bi with - [ <:rec_binding<>> -> () - | <:rec_binding< $i$ = $e$ >> -> - pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e - | <:rec_binding< $b1$ ; $b2$ >> -> - do { o#under_semi#record_binding f b1; - o#under_semi#record_binding f b2 } - | <:rec_binding< $anti:s$ >> -> o#anti f s ]; - - method mk_patt_list = - fun - [ <:patt< [$p1$ :: $p2$] >> -> - let (pl, c) = o#mk_patt_list p2 in - ([p1 :: pl], c) - | <:patt< [] >> -> ([], None) - | p -> ([], Some p) ]; - - method mk_expr_list = - fun - [ <:expr< [$e1$ :: $e2$] >> -> - let (el, c) = o#mk_expr_list e2 in - ([e1 :: el], c) - | <:expr< [] >> -> ([], None) - | e -> ([], Some e) ]; - - method expr_list f = - fun - [ [] -> pp f "[]" - | [e] -> pp f "[ %a ]" o#under_semi#expr e - | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; - - method expr_list_cons simple f e = - let (el, c) = o#mk_expr_list e in - match c with - [ None -> o#expr_list f el - | Some x -> - (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") - (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ]; - - method patt_expr_fun_args f (p, e) = - let (pl, e) = expr_fun_args e - in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e; - - method patt_class_expr_fun_args f (p, ce) = - let (pl, ce) = class_expr_fun_args ce - in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce; - - method constrain f (t1, t2) = - pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; - - method sum_type f t = - match Ast.list_of_ctyp t [] with - [ [] -> () - | ts -> - pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts ]; - - method private constructor_declaration f t = - match t with - [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 - | t -> o#ctyp f t ]; - - method string f = pp f "%s"; - method quoted_string f = pp f "%S"; - - method numeric f num suff = - if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff; - - method module_expr_get_functor_args accu = - fun - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - o#module_expr_get_functor_args [(s, mt)::accu] me - | <:module_expr< ($me$ : $mt$) >> -> (List.rev accu, me, Some mt) - | me -> (List.rev accu, me, None) ]; - - method functor_args f = list o#functor_arg "@ " f; - - method functor_arg f (s, mt) = - pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt; - - method module_rec_binding f = - fun - [ <:module_binding<>> -> () - | <:module_binding< $s$ : $mt$ = $me$ >> -> - pp f "@[<2>%a :@ %a =@ %a@]" - o#var s o#module_type mt o#module_expr me - | <:module_binding< $s$ : $mt$ >> -> - pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt - | <:module_binding< $mb1$ and $mb2$ >> -> - do { o#module_rec_binding f mb1; - pp f o#andsep; - o#module_rec_binding f mb2 } - | <:module_binding< $anti:s$ >> -> o#anti f s ]; - - method class_declaration f = - fun - [ <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "%a :@ %a" o#class_expr ce o#class_type ct - | ce -> o#class_expr f ce ]; - - method raise_match_failure f _loc = - let n = Loc.file_name _loc in - let l = Loc.start_line _loc in - let c = Loc.start_off _loc - Loc.start_bol _loc in - o#expr f <:expr< raise (Match_failure $`str:n$ $`int:l$ $`int:c$) >>; - - method node : ! 'a . formatter -> 'a -> ('a -> Loc.t) -> unit = - fun f node loc_of_node -> - o#print_comments_before (loc_of_node node) f; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#ident i1 o#ident i2 - | <:ident< $i1$ $i2$ >> -> pp f "%a@,(%a)" o#ident i1 o#ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s ]; - - method private var_ident = {< var_conversion = True >}#ident; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ ((<:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >>) as e) when semi -> - pp f "(%a)" o#reset#expr e - | ((<:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< fun [ $_$ ] >>) as e) when pipe || semi -> - pp f "(%a)" o#reset#expr e - - | <:expr< - $x$ >> -> - (* If you want to remove the space take care of - !r *) - pp f "@[<2>-@ %a@]" o#dot_expr x - | <:expr< -. $x$ >> -> - pp f "@[<2>-.@ %a@]" o#dot_expr x (* same note as above *) - | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons False f e - | <:expr@_loc< $lid:n$ $x$ $y$ >> when is_infix n -> - pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y - | <:expr< $x$ $y$ >> -> - let (a, al) = get_expr_args x [y] in - if (not curry_constr) && Ast.is_expr_constructor a then - match al with - [ [ <:expr< ($tup:_$) >> ] -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y - | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y - | al -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr a - (* The #apply_expr below may put too much parens. - However using #expr would be wrong: PR#5056. *) - (list o#under_pipe#apply_expr ",@ ") al ] - else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al] - | <:expr< $e1$.val := $e2$ >> -> - pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr@loc< fun [] >> -> - pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc - | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[function%a@]" o#match_case a - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - pp f "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" - o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3 - | <:expr< lazy $e$ >> -> pp f "@[<2>lazy@ %a@]" o#simple_expr e - | <:expr< let $rec:r$ $bi$ in $e$ >> -> - match e with - [ <:expr< let $rec:_$ $_$ in $_$ >> -> - pp f "@[<0>@[<2>let %a%a in@]@ %a@]" - o#rec_flag r o#binding bi o#reset_semi#expr e - | _ -> - pp f "@[@[<2>let %a%a@]@ @[in@ %a@]@]" - o#rec_flag r o#binding bi o#reset_semi#expr e ] - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - | <:expr< match $e$ with [ $a$ ] >> -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - o#expr e o#match_case a - | <:expr< try $e$ with [ $a$ ] >> -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - o#expr e o#match_case a - | <:expr< assert False >> -> pp f "@[<2>assert@ false@]" - | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e - | <:expr< let module $s$ = $me$ in $e$ >> -> - pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e - | <:expr< object $cst$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst - | <:expr< object ($p$ : $t$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" - o#patt p o#ctyp t o#class_str_item cst - | <:expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | e -> o#apply_expr f e ]; - - method apply_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i - | e -> o#dot_expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>!@,%a@]" o#simple_expr e - | <:expr< $e1$ . $e2$ >> -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 - | <:expr< $e1$ .( $e2$ ) >> -> - pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ .[ $e2$ ] >> -> - pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 - | <:expr< $e$ # $s$ >> -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s - | e -> o#simple_expr f e ]; - - method simple_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr<>> -> () - | <:expr< do { $e$ } >> -> - pp f "@[(%a)@]" o#seq e - | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons True f e - | <:expr< ( $tup:e$ ) >> -> - pp f "@[<1>(%a)@]" o#expr e - | <:expr< [| $e$ |] >> -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e - | <:expr< ($e$ :> $t$) >> -> - pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2 - | <:expr< ($e$ : $t$) >> -> - pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t - | <:expr< $anti:s$ >> -> o#anti f s - | <:expr< for $s$ = $e1$ $to:df$ $e2$ do { $e3$ } >> -> - pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" - o#var s o#expr e1 o#direction_flag df o#expr e2 o#seq e3 - | <:expr< $int:s$ >> -> o#numeric f s "" - | <:expr< $nativeint:s$ >> -> o#numeric f s "n" - | <:expr< $int64:s$ >> -> o#numeric f s "L" - | <:expr< $int32:s$ >> -> o#numeric f s "l" - | <:expr< $flo:s$ >> -> o#numeric f s "" - | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) - | <:expr< $id:i$ >> -> o#var_ident f i - | <:expr< { $b$ } >> -> - pp f "@[@[{%a@]@ }@]" o#record_binding b - | <:expr< { ($e$) with $b$ } >> -> - pp f "@[@[{@ (%a)@ with%a@]@ }@]" - o#expr e o#record_binding b - | <:expr< $str:s$ >> -> pp f "\"%s\"" s - | <:expr< while $e1$ do { $e2$ } >> -> - pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2 - | <:expr< ~ $s$ >> -> pp f "~%s" s - | <:expr< ~ $s$ : $e$ >> -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e - | <:expr< ? $s$ >> -> pp f "?%s" s - | <:expr< ? $s$ : $e$ >> -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e - | <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s - | <:expr< {< $b$ >} >> -> - pp f "@[@[{<%a@]@ >}@]" o#record_binding b - | <:expr< $e1$, $e2$ >> -> - pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 - | <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 - | <:expr< (module $me$ : $mt$) >> -> - pp f "@[@[(module %a : %a@])@]" - o#module_expr me o#module_type mt - | <:expr< (module $me$) >> -> - pp f "@[@[(module %a@])@]" o#module_expr me - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< let open $_$ in $_$ >> | - <:expr< assert $_$ >> | <:expr< assert False >> | - <:expr< lazy $_$ >> | <:expr< new $_$ >> | - <:expr< object ($_$) $_$ end >> -> - pp f "(%a)" o#reset#expr e ]; - - method direction_flag f b = - match b with - [ Ast.DiTo -> pp_print_string f "to" - | Ast.DiDownto -> pp_print_string f "downto" - | Ast.DiAnt s -> o#anti f s ]; - - method patt f p = - let () = o#node f p Ast.loc_of_patt in match p with - [ <:patt< ( $p1$ as $p2$ ) >> -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 - | <:patt< $i$ = $p$ >> -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p - | <:patt< $p1$; $p2$ >> -> pp f "%a;@ %a" o#patt p1 o#patt p2 - | p -> o#patt1 f p ]; - - method patt1 f = fun - [ <:patt< $p1$ | $p2$ >> -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 - | p -> o#patt2 f p ]; - - method patt2 f = fun - [ (* <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | *) p -> o#patt3 f p ]; - - method patt3 f = fun - [ <:patt< $p1$ .. $p2$ >> -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 - | <:patt< $p1$, $p2$ >> -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 - | p -> o#patt4 f p ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [x]) ] - | p -> o#patt5 f p ]; - - method patt5 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p - | <:patt< lazy $p$ >> -> - pp f "@[<2>lazy %a@]" o#simple_patt p - | <:patt< $x$ $y$ >> -> - let (a, al) = get_patt_args x [y] in - if not (Ast.is_patt_constructor a) then - Format.eprintf "WARNING: strange pattern application of a non constructor@." - else if curry_constr then - pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al] - else - match al with - [ [ <:patt< ($tup:_$) >> ] -> - pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y - | [_] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y - | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a - (list o#simple_patt ",@ ") al ] - | p -> o#simple_patt f p ]; - - method simple_patt f p = - let () = o#node f p Ast.loc_of_patt in - match p with - [ <:patt<>> -> () - | <:patt< $id:i$ >> -> o#var_ident f i - | <:patt< $anti:s$ >> -> o#anti f s - | <:patt< _ >> -> pp f "_" - | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m - | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | <:patt< { $p$ } >> -> pp f "@[{@ %a@]@ }" o#patt p - | <:patt< $str:s$ >> -> pp f "\"%s\"" s - | <:patt< ( $p$ : $t$ ) >> -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t - | <:patt< $nativeint:s$ >> -> o#numeric f s "n" - | <:patt< $int64:s$ >> -> o#numeric f s "L" - | <:patt< $int32:s$ >> -> o#numeric f s "l" - | <:patt< $int:s$ >> -> o#numeric f s "" - | <:patt< $flo:s$ >> -> o#numeric f s "" - | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) - | <:patt< ~ $s$ >> -> pp f "~%s" s - | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s - | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i - | <:patt< [| $p$ |] >> -> pp f "@[<2>[|@ %a@]@ |]" o#patt p - | <:patt< ~ $s$ : ($p$) >> -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p - | <:patt< ? $s$ >> -> pp f "?%s" s - | <:patt< ?($p$) >> -> - pp f "@[<2>?(%a)@]" o#patt_tycon p - | <:patt< ? $s$ : ($p$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p - | <:patt< ?($p$ = $e$) >> -> - pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e - | <:patt< ? $s$ : ($p$ = $e$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | - <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> as p -> - pp f "@[<1>(%a)@]" o#patt p - ]; - - method patt_tycon f = - fun - [ <:patt< ( $p$ : $t$ ) >> -> pp f "%a :@ %a" o#patt p o#ctyp t - | p -> o#patt f p ]; - - method simple_ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< $id:i$ >> -> o#ident f i - | <:ctyp< $anti:s$ >> -> o#anti f s - | <:ctyp< _ >> -> pp f "_" - | Ast.TyAnP _ -> pp f "+_" - | Ast.TyAnM _ -> pp f "-_" - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< < > >> -> pp f "< >" - | <:ctyp< < .. > >> -> pp f "< .. >" - | <:ctyp< < $t$ .. > >> -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t - | <:ctyp< < $t$ > >> -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t - | <:ctyp< '$s$ >> -> pp f "'%a" o#var s - | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t - | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t - | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t - | <:ctyp< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt - | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - let (a, al) = get_ctyp_args t2 [] in - pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 - (list o#simple_ctyp "@ ") [a::al] - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t - | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i - | <:ctyp< `$s$ >> -> pp f "`%a" o#var s - | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp<>> -> assert False - | t -> pp f "@[<1>(%a)@]" o#ctyp t ]; - - method ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< $t1$ as $t2$ >> -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< $t1$ -> $t2$ >> -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 - | <:ctyp< +'$s$ >> -> pp f "+'%a" o#var s - | <:ctyp< -'$s$ >> -> pp f "-'%a" o#var s - | <:ctyp< $t1$ | $t2$ >> -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : $t2$ >> -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$; $t2$ >> -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t$ of $<:ctyp<>>$ >> -> o#ctyp f t - | <:ctyp< $t1$ of $t2$ >> -> - pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ of & $t2$ >> -> - pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t - | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#type_params tp o#var tn; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | t -> o#ctyp1 f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1 - | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | Ast.TyTypePol (_,t1,t2) -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t - | t -> o#simple_ctyp f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2 - | <:ctyp< $_$ -> $_$ >> -> pp f "(%a)" o#ctyp t - | t -> o#ctyp f t ]; - - - method sig_item f sg = - let () = o#node f sg Ast.loc_of_sig_item in - match sg with - [ <:sig_item<>> -> () - | <:sig_item< $sg$; $<:sig_item<>>$ >> | - <:sig_item< $<:sig_item<>>$; $sg$ >> -> - o#sig_item f sg - | <:sig_item< $sg1$; $sg2$ >> -> - do { o#sig_item f sg1; cut f; o#sig_item f sg2 } - | <:sig_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | <:sig_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep - | <:sig_item< module $s1$ ($s2$ : $mt1$) : $mt2$ >> -> - let rec loop accu = - fun - [ <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> -> - loop [(s, mt1)::accu] mt2 - | mt -> (List.rev accu, mt) ] in - let (al, mt) = loop [(s2, mt1)] mt2 in - pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt semisep - | <:sig_item< module $s$ : $mt$ >> -> - pp f "@[<2>module %a :@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:sig_item< module type $s$ = $ <:module_type<>> $ >> -> - pp f "@[<2>module type %a%(%)@]" o#var s semisep - | <:sig_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:sig_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:sig_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:sig_item< value $s$ : $t$ >> -> - pp f "@[<2>%s %a :@ %a%(%)@]" - o#value_val o#var s o#ctyp t semisep - | <:sig_item< include $mt$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep - | <:sig_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:sig_item< class $ce$ >> -> - pp f "@[<2>class %a%(%)@]" o#class_type ce semisep - | <:sig_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | <:sig_item< # $_$ $_$ >> -> () - | <:sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s semisep ]; - - method str_item f st = - let () = o#node f st Ast.loc_of_str_item in - match st with - [ <:str_item<>> -> () - | <:str_item< $st$; $<:str_item<>>$ >> | - <:str_item< $<:str_item<>>$; $st$ >> -> - o#str_item f st - | <:str_item< $st1$; $st2$ >> -> - do { o#str_item f st1; cut f; o#str_item f st2 } - | <:str_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | <:str_item< exception $t$ = $sl$ >> -> - pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep - | <:str_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep - | <:str_item< module $s1$ ($s2$ : $mt1$) = $me$ >> -> - match o#module_expr_get_functor_args [(s2, mt1)] me with - [ (al, me, Some mt2) -> - pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_type mt2 - o#module_expr me semisep - | (al, me, _) -> - pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" - o#var s1 o#functor_args al o#module_expr me semisep ] - | <:str_item< module $s$ : $mt$ = $me$ >> -> - pp f "@[<2>module %a :@ %a =@ %a%(%)@]" - o#var s o#module_type mt o#module_expr me semisep - | <:str_item< module $s$ = $me$ >> -> - pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep - | <:str_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:str_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:str_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:str_item< value $rec:r$ $bi$ >> -> - pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep - | <:str_item< $exp:e$ >> -> - pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep - | <:str_item< include $me$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep - | <:str_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:str_item< class $ce$ >> -> - pp f "@[class %a%(%)@]" o#class_declaration ce semisep - | <:str_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep - | <:str_item< # $_$ $_$ >> -> () - | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep - | Ast.StExc _ _ (Ast.OAnt _) -> assert False ]; - - method module_type f mt = - let () = o#node f mt Ast.loc_of_module_type in - match mt with - [ <:module_type<>> -> assert False - | <:module_type< module type of $me$ >> -> - pp f "@[<2>module type of@ %a@]" o#module_expr me - | <:module_type< $id:i$ >> -> o#ident f i - | <:module_type< $anti:s$ >> -> o#anti f s - | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt1 o#module_type mt2 - | <:module_type< '$s$ >> -> pp f "'%a" o#var s - | <:module_type< sig $sg$ end >> -> - pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg - | <:module_type< $mt$ with $wc$ >> -> - pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc ]; - - method with_constraint f wc = - let () = o#node f wc Ast.loc_of_with_constr in - match wc with - [ <:with_constr<>> -> () - | <:with_constr< type $t1$ = $t2$ >> -> - pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ = $i2$ >> -> - pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< type $t1$ := $t2$ >> -> - pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ := $i2$ >> -> - pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< $wc1$ and $wc2$ >> -> - do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 } - | <:with_constr< $anti:s$ >> -> o#anti f s ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> -> - pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" - o#str_item st o#sig_item sg - | _ -> o#simple_module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< $id:i$ >> -> o#ident f i - | <:module_expr< $anti:s$ >> -> o#anti f s - | <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2 - | <:module_expr< functor ( $s$ : $mt$ ) -> $me$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me - | <:module_expr< struct $st$ end >> -> - pp f "@[@[struct@ %a@]@ end@]" o#str_item st - | <:module_expr< ( $me$ : $mt$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt - | <:module_expr< (value $e$ : $mt$ ) >> -> - pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt - | <:module_expr< (value $e$ ) >> -> - pp f "@[<1>(%s %a)@]" o#value_val o#expr e - ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $ce$ $e$ >> -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e - | <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i - | <:class_expr< fun $p$ -> $ce$ >> -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce - | <:class_expr< let $rec:r$ $bi$ in $ce$ >> -> - pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" - o#rec_flag r o#binding bi o#class_expr ce - | <:class_expr< object $cst$ end >> -> - pp f "@[@[object %a@]@ end@]" o#class_str_item cst - | <:class_expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct - | <:class_expr< $anti:s$ >> -> o#anti f s - | <:class_expr< $ce1$ and $ce2$ >> -> - do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 } - | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 - o#patt_class_expr_fun_args (p, ce2) - | <:class_expr< $ce1$ = $ce2$ >> -> - pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 - | _ -> assert False ]; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i - | <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< object $csg$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_sig_item csg - | <:class_type< object ($t$) $csg$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#ctyp t o#class_sig_item csg - | <:class_type< $anti:s$ >> -> o#anti f s - | <:class_type< $ct1$ and $ct2$ >> -> - do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 } - | <:class_type< $ct1$ : $ct2$ >> -> - pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 - | <:class_type< $ct1$ = $ct2$ >> -> - pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 - | _ -> assert False ]; - - method class_sig_item f csg = - let () = o#node f csg Ast.loc_of_class_sig_item in - match csg with - [ <:class_sig_item<>> -> () - | <:class_sig_item< $csg$; $<:class_sig_item<>>$ >> | - <:class_sig_item< $<:class_sig_item<>>$; $csg$ >> -> - o#class_sig_item f csg - | <:class_sig_item< $csg1$; $csg2$ >> -> - do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 } - | <:class_sig_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_sig_item< inherit $ct$ >> -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep - | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s - o#ctyp t no_semisep - | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> - pp f "@[<2>%s %a%a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t - no_semisep - | <:class_sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method class_str_item f cst = - let () = o#node f cst Ast.loc_of_class_str_item in - match cst with - [ <:class_str_item<>> -> () - | <:class_str_item< $cst$; $<:class_str_item<>>$ >> | - <:class_str_item< $<:class_str_item<>>$; $cst$ >> -> - o#class_str_item f cst - | <:class_str_item< $cst1$; $cst2$ >> -> - do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 } - | <:class_str_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ >> -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep - | <:class_str_item< initializer $e$ >> -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> -> - pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> -> - pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep - | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> - pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep - | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> -> - pp f "@[<2>%s%a %a%a =@ %a%(%)@]" - o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep - | <:class_str_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method implem f st = - match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%(%)@]@." o#expr e semisep - | st -> pp f "@[%a@]@." o#str_item st ]; - - method interf f sg = pp f "@[%a@]@." o#sig_item sg; - end; - - value with_outfile output_file fct arg = - let call close f = do { - try fct f arg with [ exn -> do { close (); raise exn } ]; - close () - } in - match output_file with - [ None -> call (fun () -> ()) std_formatter - | Some s -> - let oc = open_out s in - let f = formatter_of_out_channel oc in - call (fun () -> close_out oc) f ]; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value semisep : ref sep = ref ("@\n" : sep); - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref False; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () in - let o = o#set_semisep semisep.val in - let o = if locations.val then o#set_loc_and_comments else o in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - - value check_sep s = - if String.contains s '%' then failwith "-sep Format error, % found in string" - else (Obj.magic (Struct.Token.Eval.string s : string) : sep); - - Options.add "-l" (Arg.Int (fun i -> margin.val := i)) - " line length for pretty printing."; - - Options.add "-ss" (Arg.Unit (fun () -> semisep.val := ";;")) - " Print double semicolons."; - - Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := "")) - " Do not print double semicolons (default)."; - - Options.add "-sep" (Arg.String (fun s -> semisep.val := check_sep s)) - " Use this string between phrases."; - - Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; - - Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli deleted file mode 100644 index 0d36742b..00000000 --- a/camlp4/Camlp4/Printers/OCaml.mli +++ /dev/null @@ -1,167 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value list' : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - format unit formatter unit -> - formatter -> list 'a -> unit; - - value list : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - formatter -> list 'a -> unit; - - value lex_string : string -> Token.t; - value is_infix : string -> bool; - value is_keyword : string -> bool; - value ocaml_char : string -> string; - value get_expr_args : - Ast.expr -> list Ast.expr -> (Ast.expr * list Ast.expr); - value get_patt_args : - Ast.patt -> list Ast.patt -> (Ast.patt * list Ast.patt); - value get_ctyp_args : - Ast.ctyp -> list Ast.ctyp -> (Ast.ctyp * list Ast.ctyp); - value expr_fun_args : Ast.expr -> (list fun_binding * Ast.expr); - - (** - [new printer ~curry_constr:True ~comments:False] - Default values: curry_constr = False - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - method interf : formatter -> Ast.sig_item -> unit; - method implem : formatter -> Ast.str_item -> unit; - method sig_item : formatter -> Ast.sig_item -> unit; - method str_item : formatter -> Ast.str_item -> unit; - - value pipe : bool; - value semi : bool; - value semisep : sep; - value no_semisep : sep; - method value_val : string; - method value_let : string; - method andsep : sep; - method anti : formatter -> string -> unit; - method class_declaration : - formatter -> Ast.class_expr -> unit; - method class_expr : formatter -> Ast.class_expr -> unit; - method class_sig_item : - formatter -> Ast.class_sig_item -> unit; - method class_str_item : - formatter -> Ast.class_str_item -> unit; - method class_type : formatter -> Ast.class_type -> unit; - method constrain : - formatter -> (Ast.ctyp * Ast.ctyp) -> unit; - method ctyp : formatter -> Ast.ctyp -> unit; - method ctyp1 : formatter -> Ast.ctyp -> unit; - method constructor_type : formatter -> Ast.ctyp -> unit; - method dot_expr : formatter -> Ast.expr -> unit; - method apply_expr : formatter -> Ast.expr -> unit; - method expr : formatter -> Ast.expr -> unit; - method expr_list : formatter -> list Ast.expr -> unit; - method expr_list_cons : bool -> formatter -> Ast.expr -> unit; - method fun_binding : formatter -> fun_binding -> unit; - method functor_arg : - formatter -> (string * Ast.module_type) -> unit; - method functor_args : - formatter -> - list (string * Ast.module_type) -> unit; - method ident : formatter -> Ast.ident -> unit; - method numeric : formatter -> string -> string -> unit; - method binding : formatter -> Ast.binding -> unit; - method record_binding : formatter -> Ast.rec_binding -> unit; - method match_case : formatter -> Ast.match_case -> unit; - method match_case_aux : formatter -> Ast.match_case -> unit; - method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr); - method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt); - method simple_module_expr : formatter -> Ast.module_expr -> unit; - method module_expr : formatter -> Ast.module_expr -> unit; - method module_expr_get_functor_args : - list (string * Ast.module_type) -> - Ast.module_expr -> - (list (string * Ast.module_type) * - Ast.module_expr * - option Ast.module_type); - method module_rec_binding : formatter -> Ast.module_binding -> unit; - method module_type : formatter -> Ast.module_type -> unit; - method override_flag : formatter -> Ast.override_flag -> unit; - method mutable_flag : formatter -> Ast.mutable_flag -> unit; - method direction_flag : formatter -> Ast.direction_flag -> unit; - method rec_flag : formatter -> Ast.rec_flag -> unit; - method node : formatter -> 'b -> ('b -> Loc.t) -> unit; - method patt : formatter -> Ast.patt -> unit; - method patt1 : formatter -> Ast.patt -> unit; - method patt2 : formatter -> Ast.patt -> unit; - method patt3 : formatter -> Ast.patt -> unit; - method patt4 : formatter -> Ast.patt -> unit; - method patt5 : formatter -> Ast.patt -> unit; - method patt_tycon : formatter -> Ast.patt -> unit; - method patt_expr_fun_args : - formatter -> (fun_binding * Ast.expr) -> unit; - method patt_class_expr_fun_args : - formatter -> (Ast.patt * Ast.class_expr) -> unit; - method print_comments_before : Loc.t -> formatter -> unit; - method private_flag : formatter -> Ast.private_flag -> unit; - method virtual_flag : formatter -> Ast.virtual_flag -> unit; - method quoted_string : formatter -> string -> unit; - method raise_match_failure : formatter -> Loc.t -> unit; - method reset : 'a; - method reset_semi : 'a; - method semisep : sep; - method set_comments : bool -> 'a; - method set_curry_constr : bool -> 'a; - method set_loc_and_comments : 'a; - method set_semisep : sep -> 'a; - method simple_ctyp : formatter -> Ast.ctyp -> unit; - method simple_expr : formatter -> Ast.expr -> unit; - method simple_patt : formatter -> Ast.patt -> unit; - method seq : formatter -> Ast.expr -> unit; - method string : formatter -> string -> unit; - method sum_type : formatter -> Ast.ctyp -> unit; - method type_params : formatter -> list Ast.ctyp -> unit; - method class_params : formatter -> Ast.ctyp -> unit; - method under_pipe : 'a; - method under_semi : 'a; - method var : formatter -> string -> unit; - method with_constraint : formatter -> Ast.with_constr -> unit; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml deleted file mode 100644 index 33a85f3d..00000000 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ /dev/null @@ -1,324 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCamlr"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - open Sig; - - module PP_o = OCaml.Make Syntax; - - open PP_o; - - value pp = fprintf; - - value is_keyword = - let keywords = ["where"] - and not_keywords = ["false"; "function"; "true"; "val"] - in fun s -> not (List.mem s not_keywords) - && (is_keyword s || List.mem s keywords); - - class printer ?curry_constr:(init_curry_constr = True) ?(comments = True) () = - object (o) - inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; - - value! semisep : sep = ";"; - value! no_semisep : sep = ";"; - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value first_match_case = True; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "value"; - method value_let = "value"; - method under_pipe = o; - method under_semi = o; - method reset_semi = o; - method reset = o; - method private unset_first_match_case = {< first_match_case = False >}; - method private set_first_match_case = {< first_match_case = True >}; - - method seq f e = - let rec self right f e = - let go_right = self right and go_left = self False in - match e with - [ <:expr< let $rec:r$ $bi$ in $e1$ >> -> - if right then - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e1 - else - pp f "(%a)" o#expr e - | <:expr< do { $e$ } >> -> go_right f e - | <:expr< $e1$; $e2$ >> -> do { - pp f "%a;@ " go_left e1; - match (right, e2) with - [ (True, <:expr< let $rec:r$ $bi$ in $e3$ >>) -> - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e3 - | _ -> go_right f e2 ] } - | e -> o#expr f e ] - in self True f e; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s - | SYMBOL s -> - pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "@ %a" o#ctyp x - | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l ]; - - method match_case f = - fun - [ <:match_case<>> -> pp f "@ []" - | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method sum_type f = - fun - [ <:ctyp<>> -> pp f "[]" - | t -> pp f "@[[ %a ]@]" o#ctyp t - ]; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$ $i2$ >> -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 - | i -> o#dot_ident f i ]; - - method private dot_ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s - | i -> pp f "(%a)" o#ident i ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ] - | p -> super#patt4 f p ]; - - method expr_list_cons _ f e = - let (el, c) = o#mk_expr_list e in - match c with - [ None -> o#expr_list f el - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x ]; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr< fun $p$ -> $e$ >> when Ast.is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[fun%a@]" o#match_case a - | <:expr< assert False >> -> pp f "@[<2>assert@ False@]" - | e -> super#expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>%a.@,val@]" o#simple_expr e - | e -> super#dot_expr f e ]; - - method ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#var tn o#type_params tp; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | t -> super#ctyp f t ]; - - method simple_ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t - | t -> super#simple_ctyp f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") [a::al] ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | t -> super#ctyp1 f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 - | t -> o#ctyp f t ]; - - method str_item f st = - match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep - | st -> super#str_item f st ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 - | me -> super#module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $_$ $_$ >> -> - pp f "(%a)" o#module_expr me - | _ -> super#simple_module_expr f me ]; - - method implem f st = pp f "@[%a@]@." o#str_item st; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t - | ct -> super#class_type f ct ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t - | ce -> super#class_expr f ce ]; - end; - - value with_outfile = with_outfile; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref True; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () in - let o = if locations.val then o#set_loc_and_comments else o in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - - Options.add "-l" (Arg.Int (fun i -> margin.val := i)) - " line length for pretty printing."; - - Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff --git a/camlp4/Camlp4/Printers/OCamlr.mli b/camlp4/Camlp4/Printers/OCamlr.mli deleted file mode 100644 index 45fcbdef..00000000 --- a/camlp4/Camlp4/Printers/OCamlr.mli +++ /dev/null @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - (** - [new printer ~curry_constr:c ~comments:False] - Default values: curry_constr = True - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - inherit (OCaml.Make Syntax).printer; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml deleted file mode 100644 index 010a8310..00000000 --- a/camlp4/Camlp4/Register.ml +++ /dev/null @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module PP = Printers; -open PreCast; - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser"); -value str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser"); - -value sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer"); -value str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer"); - -value callbacks = Queue.create (); - -value loaded_modules = ref []; - -value iter_and_take_callbacks f = - let rec loop () = loop (f (Queue.take callbacks)) in - try loop () with [ Queue.Empty -> () ]; - -value declare_dyn_module m f = - begin - (* let () = Format.eprintf "declare_dyn_module: %s@." m in *) - loaded_modules.val := [ m :: loaded_modules.val ]; - Queue.add (m, f) callbacks; - end; - -value register_str_item_parser f = str_item_parser.val := f; -value register_sig_item_parser f = sig_item_parser.val := f; -value register_parser f g = - do { str_item_parser.val := f; sig_item_parser.val := g }; -value current_parser () = (str_item_parser.val, sig_item_parser.val); - -value register_str_item_printer f = str_item_printer.val := f; -value register_sig_item_printer f = sig_item_printer.val := f; -value register_printer f g = - do { str_item_printer.val := f; sig_item_printer.val := g }; -value current_printer () = (str_item_printer.val, sig_item_printer.val); - -module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ()); -end; - -module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module OCamlSyntaxExtension - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module Printer - (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPrinter - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (P : (Sig.Printer PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_printer P.print_implem P.print_interf); -end; - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlPreCastParser - (Id : Sig.Id) (P : (Sig.Parser PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_parser P.parse_implem P.parse_interf); -end; - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker AstFilters in ()); -end; - -sig_item_parser.val := Syntax.parse_interf; -str_item_parser.val := Syntax.parse_implem; - -module CurrentParser = struct - module Ast = Ast; - value parse_interf ?directive_handler loc strm = - sig_item_parser.val ?directive_handler loc strm; - value parse_implem ?directive_handler loc strm = - str_item_parser.val ?directive_handler loc strm; -end; - -module CurrentPrinter = struct - module Ast = Ast; - value print_interf ?input_file ?output_file ast = - sig_item_printer.val ?input_file ?output_file ast; - value print_implem ?input_file ?output_file ast = - str_item_printer.val ?input_file ?output_file ast; -end; - -value enable_ocaml_printer () = - let module M = OCamlPrinter PP.OCaml.Id PP.OCaml.MakeMore in (); - -value enable_ocamlr_printer () = - let module M = OCamlPrinter PP.OCamlr.Id PP.OCamlr.MakeMore in (); - -(* value enable_ocamlrr_printer () = - let module M = OCamlPrinter PP.OCamlrr.Id PP.OCamlrr.MakeMore in (); *) - -value enable_dump_ocaml_ast_printer () = - let module M = OCamlPrinter PP.DumpOCamlAst.Id PP.DumpOCamlAst.Make in (); - -value enable_dump_camlp4_ast_printer () = - let module M = Printer PP.DumpCamlp4Ast.Id PP.DumpCamlp4Ast.Make in (); - -value enable_null_printer () = - let module M = Printer PP.Null.Id PP.Null.Make in (); diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli deleted file mode 100644 index d997d417..00000000 --- a/camlp4/Camlp4/Register.mli +++ /dev/null @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Plugin - (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end; - -module SyntaxPlugin - (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : - sig end; - -module SyntaxExtension - (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end; - -module OCamlSyntaxExtension - (Id : Sig.Id) - (SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) - : sig end; - -(** {6 Registering Parsers} *) - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit; -value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit; -value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit; -value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item); - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlPreCastParser - (Id : Sig.Id) (Parser : (Sig.Parser PreCast.Ast).S) : sig end; - -(** {6 Registering Printers} *) - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit; -value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit; -value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit; -value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item); - -module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (Printer : (Sig.Printer PreCast.Ast).S) : - sig end; - -(** {6 Registering Filters} *) - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end; - -value declare_dyn_module : string -> (unit -> unit) -> unit; -value iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit; -value loaded_modules : ref (list string); - -module CurrentParser : (Sig.Parser PreCast.Ast).S; -module CurrentPrinter : (Sig.Printer PreCast.Ast).S; - -value enable_ocaml_printer : unit -> unit; -value enable_ocamlr_printer : unit -> unit; -(* value enable_ocamlrr_printer : unit -> unit; *) -value enable_null_printer : unit -> unit; -value enable_dump_ocaml_ast_printer : unit -> unit; -value enable_dump_camlp4_ast_printer : unit -> unit; diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml deleted file mode 100644 index bae3da5a..00000000 --- a/camlp4/Camlp4/Sig.ml +++ /dev/null @@ -1,1445 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(** Camlp4 signature repository *) - -(** {6 Basic signatures} *) - -(** Signature with just a type. *) -module type Type = sig - type t; -end; - -(** Signature for errors modules, an Error modules can be registred with - the {!ErrorHandler.Register} functor in order to be well printed. *) -module type Error = sig - type t; - exception E of t; - value to_string : t -> string; - value print : Format.formatter -> t -> unit; -end; - -(** A signature for extensions identifiers. *) -module type Id = sig - - (** The name of the extension, typically the module name. *) - value name : string; - - (** The version of the extension, typically $ Id$ with a versionning system. *) - value version : string; - -end; - -(** A signature for warnings abstract from locations. *) -module Warning (Loc : Type) = struct - module type S = sig - type warning = Loc.t -> string -> unit; - value default_warning : warning; - value current_warning : ref warning; - value print_warning : warning; - end; -end; - -(** {6 Advanced signatures} *) - -(** A signature for locations. *) -module type Loc = sig - - (** The type of locations. Note that, as for OCaml locations, - character numbers in locations refer to character numbers in the - parsed character stream, while line numbers refer to line - numbers in the source file. The source file and the parsed - character stream differ, for instance, when the parsed character - stream contains a line number directive. The line number - directive will only update the file-name field and the - line-number field of the position. It makes therefore no sense - to use character numbers with the source file if the sources - contain line number directives. *) - type t; - - (** Return a start location for the given file name. - This location starts at the begining of the file. *) - value mk : string -> t; - - (** The [ghost] location can be used when no location - information is available. *) - value ghost : t; - - (** {6 Conversion functions} *) - - (** Return a location where both positions are set the given position. *) - value of_lexing_position : Lexing.position -> t; - - (** Return an OCaml location. *) - value to_ocaml_location : t -> Camlp4_import.Location.t; - - (** Return a location from an OCaml location. *) - value of_ocaml_location : Camlp4_import.Location.t -> t; - - (** Return a location from ocamllex buffer. *) - value of_lexbuf : Lexing.lexbuf -> t; - - (** Return a location from [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value of_tuple : (string * int * int * int * int * int * int * bool) -> t; - - (** Return [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value to_tuple : t -> (string * int * int * int * int * int * int * bool); - - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at - [loc2]. *) - value merge : t -> t -> t; - - (** The stop pos becomes equal to the start pos. *) - value join : t -> t; - - (** [move selector n loc] - Return the location where positions are moved. - Affected positions are chosen with [selector]. - Returned positions have their character offset plus [n]. *) - value move : [= `start | `stop | `both ] -> int -> t -> t; - - (** [shift n loc] Return the location where the new start position is the old - stop position, and where the new stop position character offset is the - old one plus [n]. *) - value shift : int -> t -> t; - - (** [move_line n loc] Return the location with the old line count plus [n]. - The "begin of line" of both positions become the current offset. *) - value move_line : int -> t -> t; - - (** {6 Accessors} *) - - (** Return the file name *) - value file_name : t -> string; - - (** Return the line number of the begining of this location. *) - value start_line : t -> int; - - (** Return the line number of the ending of this location. *) - value stop_line : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's begining. *) - value start_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's ending. *) - value stop_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - of the begining of this location. *) - value start_off : t -> int; - - (** Return the number of characters from the begining of the stream - of the ending of this location. *) - value stop_off : t -> int; - - (** Return the start position as a Lexing.position. *) - value start_pos : t -> Lexing.position; - - (** Return the stop position as a Lexing.position. *) - value stop_pos : t -> Lexing.position; - - (** Generally, return true if this location does not come - from an input stream. *) - value is_ghost : t -> bool; - - (** Return the associated ghost location. *) - value ghostify : t -> t; - - (** Return the location with the give file name *) - value set_file_name : string -> t -> t; - - (** [strictly_before loc1 loc2] True if the stop position of [loc1] is - strictly_before the start position of [loc2]. *) - value strictly_before : t -> t -> bool; - - (** Return the location with an absolute file name. *) - value make_absolute : t -> t; - - (** Print the location into the formatter in a format suitable for error - reporting. *) - value print : Format.formatter -> t -> unit; - - (** Print the location in a short format useful for debugging. *) - value dump : Format.formatter -> t -> unit; - - (** Same as {!print} but return a string instead of printting it. *) - value to_string : t -> string; - - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [Loc.raise]. *) - exception Exc_located of t and exn; - - (** [raise loc e], if [e] is already an [Exc_located] exception, - re-raise it, else raise the exception [Exc_located loc e]. *) - value raise : t -> exn -> 'a; - - (** The name of the location variable used in grammars and in - the predefined quotations for OCaml syntax trees. Default: [_loc]. *) - value name : ref string; - -end; - -(** Abstract syntax tree minimal signature. - Types of this signature are abstract. - See the {!Camlp4Ast} signature for a concrete definition. *) -module type Ast = sig - - (** {6 Syntactic categories as abstract types} *) - - type loc; - type meta_bool; - type meta_option 'a; - type meta_list 'a; - type ctyp; - type patt; - type expr; - type module_type; - type sig_item; - type with_constr; - type module_expr; - type str_item; - type class_type; - type class_sig_item; - type class_expr; - type class_str_item; - type match_case; - type ident; - type binding; - type rec_binding; - type module_binding; - type rec_flag; - type direction_flag; - type mutable_flag; - type private_flag; - type virtual_flag; - type row_var_flag; - type override_flag; - - (** {6 Location accessors} *) - - value loc_of_ctyp : ctyp -> loc; - value loc_of_patt : patt -> loc; - value loc_of_expr : expr -> loc; - value loc_of_module_type : module_type -> loc; - value loc_of_module_expr : module_expr -> loc; - value loc_of_sig_item : sig_item -> loc; - value loc_of_str_item : str_item -> loc; - value loc_of_class_type : class_type -> loc; - value loc_of_class_sig_item : class_sig_item -> loc; - value loc_of_class_expr : class_expr -> loc; - value loc_of_class_str_item : class_str_item -> loc; - value loc_of_with_constr : with_constr -> loc; - value loc_of_binding : binding -> loc; - value loc_of_rec_binding : rec_binding -> loc; - value loc_of_module_binding : module_binding -> loc; - value loc_of_match_case : match_case -> loc; - value loc_of_ident : ident -> loc; - - (** {6 Traversals} *) - - (** This class is the base class for map traversal on the Ast. - To make a custom traversal class one just extend it like that: - - This example swap pairs expression contents: - open Camlp4.PreCast; - [class swap = object - inherit Ast.map as super; - method expr e = - match super#expr e with - \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> - | e -> e \]; - end; - value _loc = Loc.ghost; - value map = (new swap)#expr; - assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] - *) - class map : object ('self_type) - method string : string -> string; - method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; - method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; - method loc : loc -> loc; - method expr : expr -> expr; - method patt : patt -> patt; - method ctyp : ctyp -> ctyp; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method override_flag : override_flag -> override_flag; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** Fold style traversal *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method meta_bool : meta_bool -> 'self_type; - method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; - method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method loc : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - -end; - - -(** Signature for OCaml syntax trees. *) (* - This signature is an extension of {!Ast} - It provides: - - Types for all kinds of structure. - - Map: A base class for map traversals. - - Map classes and functions for common kinds. - - == Core language == - ctyp :: Representaion of types - patt :: The type of patterns - expr :: The type of expressions - match_case :: The type of cases for match/function/try constructions - ident :: The type of identifiers (including path like Foo(X).Bar.y) - binding :: The type of let bindings - rec_binding :: The type of record definitions - - == Modules == - module_type :: The type of module types - sig_item :: The type of signature items - str_item :: The type of structure items - module_expr :: The type of module expressions - module_binding :: The type of recursive module definitions - with_constr :: The type of `with' constraints - - == Classes == - class_type :: The type of class types - class_sig_item :: The type of class signature items - class_expr :: The type of class expressions - class_str_item :: The type of class structure items - *) -module type Camlp4Ast = sig - - (** The inner module for locations *) - module Loc : Loc; - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - - value loc_of_ctyp : ctyp -> loc; - value loc_of_patt : patt -> loc; - value loc_of_expr : expr -> loc; - value loc_of_module_type : module_type -> loc; - value loc_of_module_expr : module_expr -> loc; - value loc_of_sig_item : sig_item -> loc; - value loc_of_str_item : str_item -> loc; - value loc_of_class_type : class_type -> loc; - value loc_of_class_sig_item : class_sig_item -> loc; - value loc_of_class_expr : class_expr -> loc; - value loc_of_class_str_item : class_str_item -> loc; - value loc_of_with_constr : with_constr -> loc; - value loc_of_binding : binding -> loc; - value loc_of_rec_binding : rec_binding -> loc; - value loc_of_module_binding : module_binding -> loc; - value loc_of_match_case : match_case -> loc; - value loc_of_ident : ident -> loc; - - module Meta : sig - module type META_LOC = sig - (* The first location is where to put the returned pattern. - Generally it's _loc to match with <:patt< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_patt : loc -> loc -> patt; - (* The first location is where to put the returned expression. - Generally it's _loc to match with <:expr< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_expr : loc -> loc -> expr; - end; - module MetaLoc : sig - value meta_loc_patt : loc -> loc -> patt; - value meta_loc_expr : loc -> loc -> expr; - end; - module MetaGhostLoc : sig - value meta_loc_patt : loc -> 'a -> patt; - value meta_loc_expr : loc -> 'a -> expr; - end; - module MetaLocVar : sig - value meta_loc_patt : loc -> 'a -> patt; - value meta_loc_expr : loc -> 'a -> expr; - end; - module Make (MetaLoc : META_LOC) : sig - module Expr : sig - value meta_string : loc -> string -> expr; - value meta_int : loc -> string -> expr; - value meta_float : loc -> string -> expr; - value meta_char : loc -> string -> expr; - value meta_bool : loc -> bool -> expr; - value meta_list : (loc -> 'a -> expr) -> loc -> list 'a -> expr; - value meta_binding : loc -> binding -> expr; - value meta_rec_binding : loc -> rec_binding -> expr; - value meta_class_expr : loc -> class_expr -> expr; - value meta_class_sig_item : loc -> class_sig_item -> expr; - value meta_class_str_item : loc -> class_str_item -> expr; - value meta_class_type : loc -> class_type -> expr; - value meta_ctyp : loc -> ctyp -> expr; - value meta_expr : loc -> expr -> expr; - value meta_ident : loc -> ident -> expr; - value meta_match_case : loc -> match_case -> expr; - value meta_module_binding : loc -> module_binding -> expr; - value meta_module_expr : loc -> module_expr -> expr; - value meta_module_type : loc -> module_type -> expr; - value meta_patt : loc -> patt -> expr; - value meta_sig_item : loc -> sig_item -> expr; - value meta_str_item : loc -> str_item -> expr; - value meta_with_constr : loc -> with_constr -> expr; - value meta_rec_flag : loc -> rec_flag -> expr; - value meta_mutable_flag : loc -> mutable_flag -> expr; - value meta_virtual_flag : loc -> virtual_flag -> expr; - value meta_private_flag : loc -> private_flag -> expr; - value meta_row_var_flag : loc -> row_var_flag -> expr; - value meta_override_flag : loc -> override_flag -> expr; - value meta_direction_flag : loc -> direction_flag -> expr; - end; - module Patt : sig - value meta_string : loc -> string -> patt; - value meta_int : loc -> string -> patt; - value meta_float : loc -> string -> patt; - value meta_char : loc -> string -> patt; - value meta_bool : loc -> bool -> patt; - value meta_list : (loc -> 'a -> patt) -> loc -> list 'a -> patt; - value meta_binding : loc -> binding -> patt; - value meta_rec_binding : loc -> rec_binding -> patt; - value meta_class_expr : loc -> class_expr -> patt; - value meta_class_sig_item : loc -> class_sig_item -> patt; - value meta_class_str_item : loc -> class_str_item -> patt; - value meta_class_type : loc -> class_type -> patt; - value meta_ctyp : loc -> ctyp -> patt; - value meta_expr : loc -> expr -> patt; - value meta_ident : loc -> ident -> patt; - value meta_match_case : loc -> match_case -> patt; - value meta_module_binding : loc -> module_binding -> patt; - value meta_module_expr : loc -> module_expr -> patt; - value meta_module_type : loc -> module_type -> patt; - value meta_patt : loc -> patt -> patt; - value meta_sig_item : loc -> sig_item -> patt; - value meta_str_item : loc -> str_item -> patt; - value meta_with_constr : loc -> with_constr -> patt; - value meta_rec_flag : loc -> rec_flag -> patt; - value meta_mutable_flag : loc -> mutable_flag -> patt; - value meta_virtual_flag : loc -> virtual_flag -> patt; - value meta_private_flag : loc -> private_flag -> patt; - value meta_row_var_flag : loc -> row_var_flag -> patt; - value meta_override_flag : loc -> override_flag -> patt; - value meta_direction_flag : loc -> direction_flag -> patt; - end; - end; - end; - - (** See {!Ast.map}. *) - class map : object ('self_type) - method string : string -> string; - method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; - method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; - method loc : loc -> loc; - method expr : expr -> expr; - method patt : patt -> patt; - method ctyp : ctyp -> ctyp; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - method override_flag : override_flag -> override_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** See {!Ast.fold}. *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method meta_bool : meta_bool -> 'self_type; - method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; - method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method loc : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - - value map_expr : (expr -> expr) -> map; - value map_patt : (patt -> patt) -> map; - value map_ctyp : (ctyp -> ctyp) -> map; - value map_str_item : (str_item -> str_item) -> map; - value map_sig_item : (sig_item -> sig_item) -> map; - value map_loc : (loc -> loc) -> map; - - value ident_of_expr : expr -> ident; - value ident_of_patt : patt -> ident; - value ident_of_ctyp : ctyp -> ident; - - value biAnd_of_list : list binding -> binding; - value rbSem_of_list : list rec_binding -> rec_binding; - value paSem_of_list : list patt -> patt; - value paCom_of_list : list patt -> patt; - value tyOr_of_list : list ctyp -> ctyp; - value tyAnd_of_list : list ctyp -> ctyp; - value tyAmp_of_list : list ctyp -> ctyp; - value tySem_of_list : list ctyp -> ctyp; - value tyCom_of_list : list ctyp -> ctyp; - value tySta_of_list : list ctyp -> ctyp; - value stSem_of_list : list str_item -> str_item; - value sgSem_of_list : list sig_item -> sig_item; - value crSem_of_list : list class_str_item -> class_str_item; - value cgSem_of_list : list class_sig_item -> class_sig_item; - value ctAnd_of_list : list class_type -> class_type; - value ceAnd_of_list : list class_expr -> class_expr; - value wcAnd_of_list : list with_constr -> with_constr; - value meApp_of_list : list module_expr -> module_expr; - value mbAnd_of_list : list module_binding -> module_binding; - value mcOr_of_list : list match_case -> match_case; - value idAcc_of_list : list ident -> ident; - value idApp_of_list : list ident -> ident; - value exSem_of_list : list expr -> expr; - value exCom_of_list : list expr -> expr; - - value list_of_ctyp : ctyp -> list ctyp -> list ctyp; - value list_of_binding : binding -> list binding -> list binding; - value list_of_rec_binding : rec_binding -> list rec_binding -> list rec_binding; - value list_of_with_constr : with_constr -> list with_constr -> list with_constr; - value list_of_patt : patt -> list patt -> list patt; - value list_of_expr : expr -> list expr -> list expr; - value list_of_str_item : str_item -> list str_item -> list str_item; - value list_of_sig_item : sig_item -> list sig_item -> list sig_item; - value list_of_class_sig_item : class_sig_item -> list class_sig_item -> list class_sig_item; - value list_of_class_str_item : class_str_item -> list class_str_item -> list class_str_item; - value list_of_class_type : class_type -> list class_type -> list class_type; - value list_of_class_expr : class_expr -> list class_expr -> list class_expr; - value list_of_module_expr : module_expr -> list module_expr -> list module_expr; - value list_of_module_binding : module_binding -> list module_binding -> list module_binding; - value list_of_match_case : match_case -> list match_case -> list match_case; - value list_of_ident : ident -> list ident -> list ident; - - (** Like [String.escape] but takes care to not - escape antiquotations strings. *) - value safe_string_escaped : string -> string; - - (** Returns True if the given pattern is irrefutable. *) - value is_irrefut_patt : patt -> bool; - - value is_constructor : ident -> bool; - value is_patt_constructor : patt -> bool; - value is_expr_constructor : expr -> bool; - - value ty_of_stl : (Loc.t * string * list ctyp) -> ctyp; - value ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp; - value bi_of_pe : (patt * expr) -> binding; - value pel_of_binding : binding -> list (patt * expr); - value binding_of_pel : list (patt * expr) -> binding; - value sum_type_of_list : list (Loc.t * string * list ctyp) -> ctyp; - value record_type_of_list : list (Loc.t * string * bool * ctyp) -> ctyp; -end; - -(** This functor is a restriction functor. - It takes a Camlp4Ast module and gives the Ast one. - Typical use is for [with] constraints. - Example: ... with module Ast = Camlp4.Sig.Camlp4AstToAst Camlp4Ast *) -module Camlp4AstToAst (M : Camlp4Ast) : Ast - with type loc = M.loc - and type meta_bool = M.meta_bool - and type meta_option 'a = M.meta_option 'a - and type meta_list 'a = M.meta_list 'a - and type ctyp = M.ctyp - and type patt = M.patt - and type expr = M.expr - and type module_type = M.module_type - and type sig_item = M.sig_item - and type with_constr = M.with_constr - and type module_expr = M.module_expr - and type str_item = M.str_item - and type class_type = M.class_type - and type class_sig_item = M.class_sig_item - and type class_expr = M.class_expr - and type class_str_item = M.class_str_item - and type binding = M.binding - and type rec_binding = M.rec_binding - and type module_binding = M.module_binding - and type match_case = M.match_case - and type ident = M.ident - and type rec_flag = M.rec_flag - and type direction_flag = M.direction_flag - and type mutable_flag = M.mutable_flag - and type private_flag = M.private_flag - and type virtual_flag = M.virtual_flag - and type row_var_flag = M.row_var_flag - and type override_flag = M.override_flag -= M; - -(** Concrete definition of Camlp4 ASTs abstracted from locations. - Since the Ast contains locations, this functor produces Ast types - for a given location type. *) -module MakeCamlp4Ast (Loc : Type) = struct - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - -end; - -(** {6 Filters} *) - -(** A type for stream filters. *) -type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); - -(** Registerinng and folding of Ast filters. - Two kinds of filters must be handled: - - Implementation filters: str_item -> str_item. - - Interface filters: sig_item -> sig_item. *) -module type AstFilters = sig - - module Ast : Camlp4Ast; - - type filter 'a = 'a -> 'a; - - value register_sig_item_filter : (filter Ast.sig_item) -> unit; - value register_str_item_filter : (filter Ast.str_item) -> unit; - value register_topphrase_filter : (filter Ast.str_item) -> unit; - - value fold_interf_filters : ('a -> filter Ast.sig_item -> 'a) -> 'a -> 'a; - value fold_implem_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - value fold_topphrase_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - -end; - -(** ASTs as one single dynamic type *) -module type DynAst = sig - module Ast : Ast; - type tag 'a; - - value ctyp_tag : tag Ast.ctyp; - value patt_tag : tag Ast.patt; - value expr_tag : tag Ast.expr; - value module_type_tag : tag Ast.module_type; - value sig_item_tag : tag Ast.sig_item; - value with_constr_tag : tag Ast.with_constr; - value module_expr_tag : tag Ast.module_expr; - value str_item_tag : tag Ast.str_item; - value class_type_tag : tag Ast.class_type; - value class_sig_item_tag : tag Ast.class_sig_item; - value class_expr_tag : tag Ast.class_expr; - value class_str_item_tag : tag Ast.class_str_item; - value match_case_tag : tag Ast.match_case; - value ident_tag : tag Ast.ident; - value binding_tag : tag Ast.binding; - value rec_binding_tag : tag Ast.rec_binding; - value module_binding_tag : tag Ast.module_binding; - - value string_of_tag : tag 'a -> string; - - module Pack (X : sig type t 'a; end) : sig - type pack; - value pack : tag 'a -> X.t 'a -> pack; - value unpack : tag 'a -> pack -> X.t 'a; - value print_tag : Format.formatter -> pack -> unit; - end; -end; - - -(** {6 Quotation operations} *) - -(** The generic quotation type. - To see how fields are used here is an example: - <:q_name@q_loc> - The last one, q_shift is equal to the length of "<:q_name@q_loc<". *) -type quotation = - { q_name : string ; - q_loc : string ; - q_shift : int ; - q_contents : string }; - -(** The signature for a quotation expander registery. *) -module type Quotation = sig - module Ast : Ast; - module DynAst : DynAst with module Ast = Ast; - open Ast; - - (** The [loc] is the initial location. The option string is the optional name - for the location variable. The string is the quotation contents. *) - type expand_fun 'a = loc -> option string -> string -> 'a; - - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - value add : string -> DynAst.tag 'a -> expand_fun 'a -> unit; - - (** [find name] returns the expander of the given quotation name. *) - value find : string -> DynAst.tag 'a -> expand_fun 'a; - - (** [default] holds the default quotation name. *) - value default : ref string; - - (** [parse_quotation_result parse_function loc position_tag quotation quotation_result] - It's a parser wrapper, this function handles the error reporting for you. *) - value parse_quotation_result : - (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a; - - (** function translating quotation names; default = identity *) - value translate : ref (string -> string); - - value expand : loc -> quotation -> DynAst.tag 'a -> 'a; - - (** [dump_file] optionally tells Camlp4 to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) - value dump_file : ref (option string); - - module Error : Error; - -end; - -(** {6 Tokens} *) - -(** A signature for tokens. *) -module type Token = sig - - module Loc : Loc; - - type t; - - value to_string : t -> string; - - value print : Format.formatter -> t -> unit; - - value match_keyword : string -> t -> bool; - - value extract_string : t -> string; - - module Filter : sig - - type token_filter = stream_filter t Loc.t; - - (** The type for this filter chain. - A basic implementation just store the [is_keyword] function given - by [mk] and use it in the [filter] function. *) - type t; - - (** The given predicate function returns true if the given string - is a keyword. This function can be used in filters to translate - identifier tokens to keyword tokens. *) - value mk : (string -> bool) -> t; - - (** This function allows to register a new filter to the token filter chain. - You can choose to not support these and raise an exception. *) - value define_filter : t -> (token_filter -> token_filter) -> unit; - - (** This function filter the given stream and return a filtered stream. - A basic implementation just match identifiers against the [is_keyword] - function to produce token keywords instead. *) - value filter : t -> token_filter; - - (** Called by the grammar system when a keyword is used. - The boolean argument is True when it's the first time that keyword - is used. If you do not care about this information just return [()]. *) - value keyword_added : t -> string -> bool -> unit; - - (** Called by the grammar system when a keyword is no longer used. - If you do not care about this information just return [()]. *) - value keyword_removed : t -> string -> unit; - end; - - module Error : Error; -end; - -(** This signature describes tokens for the OCaml and the Revised - syntax lexing rules. For some tokens the data constructor holds two - representations with the evaluated one and the source one. For example - the INT data constructor holds an integer and a string, this string can - contains more information that's needed for a good pretty-printing - ("42", "4_2", "0000042", "0b0101010"...). - - The meaning of the tokens are: -- [KEYWORD s] is the keyword [s]. -- [LIDENT s] is the ident [s] starting with a lowercase letter. -- [UIDENT s] is the ident [s] starting with an uppercase letter. -- [INT i s] (resp. [INT32 i s], [INT64 i s] and [NATIVEINT i s]) - the integer constant [i] whose string source is [s]. -- [FLOAT f s] is the float constant [f] whose string source is [s]. -- [STRING s s'] is the string constant [s] whose string source is [s']. -- [CHAR c s] is the character constant [c] whose string source is [s]. -- [QUOTATION q] is a quotation [q], see {!Quotation.t} for more information. -- [ANTIQUOT n s] is an antiquotation [n] holding the string [s]. -- [EOI] is the end of input. - - Warning: the second string associated with the constructor [STRING] is - the string found in the source without any interpretation. In particular, - the backslashes are not interpreted. For example, if the input is ["\n"] - the string is *not* a string with one element containing the character - "return", but a string of two elements: the backslash and the character - ["n"]. To interpret a string use the first string of the [STRING] - constructor (or if you need to compute it use the module - {!Camlp4.Struct.Token.Eval}. Same thing for the constructor [CHAR]. *) -type camlp4_token = - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -(** A signature for specialized tokens. *) -module type Camlp4Token = Token with type t = camlp4_token; - -(** {6 Dynamic loaders} *) - -(** A signature for dynamic loaders. *) -module type DynLoader = sig - type t; - exception Error of string and string; - - (** [mk ?ocaml_stdlib ?camlp4_stdlib] - The stdlib flag is true by default. - To disable it use: [mk ~ocaml_stdlib:False] *) - value mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t; - - (** Fold over the current load path list. *) - value fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a; - - (** [load f] Load the file [f]. If [f] is not an absolute path name, - the load path list used to find the directory of [f]. *) - value load : t -> string -> unit; - - (** [include_dir d] Add the directory [d] in the current load path - list (like the common -I option). *) - value include_dir : t -> string -> unit; - - (** [find_in_path f] Returns the full path of the file [f] if - [f] is in the current load path, raises [Not_found] otherwise. *) - value find_in_path : t -> string -> string; - - (** [is_native] [True] if we are in native code, [False] for bytecode. *) - value is_native : bool; -end; - -(** A signature for grammars. *) -module Grammar = struct - - (** Internal signature for sematantic actions of grammars, - not for the casual user. These functions are unsafe. *) - module type Action = sig - type t ; - - value mk : 'a -> t; - value get : t -> 'a; - value getf : t -> ('a -> 'b); - value getf2 : t -> ('a -> 'b -> 'c); - end; - - type assoc = - [ NonA - | RightA - | LeftA ]; - - type position = - [ First - | Last - | Before of string - | After of string - | Level of string ]; - - (** Common signature for {!Sig.Grammar.Static} and {!Sig.Grammar.Dynamic}. *) - module type Structure = sig - module Loc : Loc; - module Action : Action; - module Token : Token with module Loc = Loc; - - type gram; - type internal_entry; - type tree; - - type token_pattern = ((Token.t -> bool) * string); - type token_info; - type token_stream = Stream.t (Token.t * token_info); - - value token_location : token_info -> Loc.t; - - type symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ]; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - end; - - (** Signature for Camlp4 grammars. Here the dynamic means that you can produce as - many grammar values as needed with a single grammar module. - If you do not need many grammar values it's preferable to use a static one. *) - module type Dynamic = sig - include Structure; - - (** Make a new grammar. *) - value mk : unit -> gram; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : gram -> string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - gram -> string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** Same as {!print} but show the left-factorization. *) - value dump : Format.formatter -> t 'a -> unit; - - (**/**) - value obj : t 'a -> internal_entry; - value clear : t 'a -> unit; - (**/**) - end; - - (** [get_filter g] Get the {!Token.Filter} associated to the [g]. *) - value get_filter : gram -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : gram -> Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : gram -> Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : gram -> not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - - (** Signature for Camlp4 grammars. Here the static means that there is only - one grammar value by grammar module. If you do not need to store the grammar - value it's preferable to use a static one. *) - module type Static = sig - include Structure; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** Same as {!print} but show the left-factorization. *) - value dump : Format.formatter -> t 'a -> unit; - - (**/**) - value obj : t 'a -> internal_entry; - value clear : t 'a -> unit; - (**/**) - end; - - (** Get the {!Token.Filter} associated to the grammar module. *) - value get_filter : unit -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - -end; - -(** A signature for lexers. *) -module type Lexer = sig - module Loc : Loc; - module Token : Token with module Loc = Loc; - module Error : Error; - - (** The constructor for a lexing function. The character stream is the input - stream to be lexed. The result is a stream of pairs of a token and - a location. - The lexer do not use global (mutable) variables: instantiations - of [Lexer.mk ()] do not perturb each other. *) - value mk : unit -> (Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t)); -end; - - -(** A signature for parsers abstract from ASTs. *) -module Parser (Ast : Ast) = struct - module type SIMPLE = sig - (** The parse function for expressions. - The underlying expression grammar entry is generally "expr; EOI". *) - value parse_expr : Ast.loc -> string -> Ast.expr; - - (** The parse function for patterns. - The underlying pattern grammar entry is generally "patt; EOI". *) - value parse_patt : Ast.loc -> string -> Ast.patt; - end; - - module type S = sig - - (** Called when parsing an implementation (ml file) to build the syntax - tree; the returned list contains the phrases (structure items) as a - single "declare" node (a list of structure items); if the parser - encounter a directive it stops (since the directive may change the - syntax), the given [directive_handler] function evaluates it and - the parsing starts again. *) - value parse_implem : ?directive_handler:(Ast.str_item -> option Ast.str_item) -> - Ast.loc -> Stream.t char -> Ast.str_item; - - (** Same as {!parse_implem} but for interface (mli file). *) - value parse_interf : ?directive_handler:(Ast.sig_item -> option Ast.sig_item) -> - Ast.loc -> Stream.t char -> Ast.sig_item; - end; -end; - -(** A signature for printers abstract from ASTs. *) -module Printer (Ast : Ast) = struct - module type S = sig - - value print_interf : ?input_file:string -> ?output_file:string -> - Ast.sig_item -> unit; - value print_implem : ?input_file:string -> ?output_file:string -> - Ast.str_item -> unit; - - end; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Syntax = sig - module Loc : Loc; - module Ast : Ast with type loc = Loc.t; - module Token : Token with module Loc = Loc; - module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module Quotation : Quotation with module Ast = Ast; - - module AntiquotSyntax : (Parser Ast).SIMPLE; - - include (Warning Loc).S; - include (Parser Ast).S; - include (Printer Ast).S; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Camlp4Syntax = sig - module Loc : Loc; - - module Ast : Camlp4Ast with module Loc = Loc; - module Token : Camlp4Token with module Loc = Loc; - - module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module Quotation : Quotation with module Ast = Camlp4AstToAst Ast; - - module AntiquotSyntax : (Parser Ast).SIMPLE; - - include (Warning Loc).S; - include (Parser Ast).S; - include (Printer Ast).S; - - value interf : Gram.Entry.t (list Ast.sig_item * option Loc.t); - value implem : Gram.Entry.t (list Ast.str_item * option Loc.t); - value top_phrase : Gram.Entry.t (option Ast.str_item); - value use_file : Gram.Entry.t (list Ast.str_item * option Loc.t); - value a_CHAR : Gram.Entry.t string; - value a_FLOAT : Gram.Entry.t string; - value a_INT : Gram.Entry.t string; - value a_INT32 : Gram.Entry.t string; - value a_INT64 : Gram.Entry.t string; - value a_LABEL : Gram.Entry.t string; - value a_LIDENT : Gram.Entry.t string; - value a_NATIVEINT : Gram.Entry.t string; - value a_OPTLABEL : Gram.Entry.t string; - value a_STRING : Gram.Entry.t string; - value a_UIDENT : Gram.Entry.t string; - value a_ident : Gram.Entry.t string; - value amp_ctyp : Gram.Entry.t Ast.ctyp; - value and_ctyp : Gram.Entry.t Ast.ctyp; - value match_case : Gram.Entry.t Ast.match_case; - value match_case0 : Gram.Entry.t Ast.match_case; - value match_case_quot : Gram.Entry.t Ast.match_case; - value binding : Gram.Entry.t Ast.binding; - value binding_quot : Gram.Entry.t Ast.binding; - value rec_binding_quot : Gram.Entry.t Ast.rec_binding; - value class_declaration : Gram.Entry.t Ast.class_expr; - value class_description : Gram.Entry.t Ast.class_type; - value class_expr : Gram.Entry.t Ast.class_expr; - value class_expr_quot : Gram.Entry.t Ast.class_expr; - value class_fun_binding : Gram.Entry.t Ast.class_expr; - value class_fun_def : Gram.Entry.t Ast.class_expr; - value class_info_for_class_expr : Gram.Entry.t Ast.class_expr; - value class_info_for_class_type : Gram.Entry.t Ast.class_type; - value class_longident : Gram.Entry.t Ast.ident; - value class_longident_and_param : Gram.Entry.t Ast.class_expr; - value class_name_and_param : Gram.Entry.t (string * Ast.ctyp); - value class_sig_item : Gram.Entry.t Ast.class_sig_item; - value class_sig_item_quot : Gram.Entry.t Ast.class_sig_item; - value class_signature : Gram.Entry.t Ast.class_sig_item; - value class_str_item : Gram.Entry.t Ast.class_str_item; - value class_str_item_quot : Gram.Entry.t Ast.class_str_item; - value class_structure : Gram.Entry.t Ast.class_str_item; - value class_type : Gram.Entry.t Ast.class_type; - value class_type_declaration : Gram.Entry.t Ast.class_type; - value class_type_longident : Gram.Entry.t Ast.ident; - value class_type_longident_and_param : Gram.Entry.t Ast.class_type; - value class_type_plus : Gram.Entry.t Ast.class_type; - value class_type_quot : Gram.Entry.t Ast.class_type; - value comma_ctyp : Gram.Entry.t Ast.ctyp; - value comma_expr : Gram.Entry.t Ast.expr; - value comma_ipatt : Gram.Entry.t Ast.patt; - value comma_patt : Gram.Entry.t Ast.patt; - value comma_type_parameter : Gram.Entry.t Ast.ctyp; - value constrain : Gram.Entry.t (Ast.ctyp * Ast.ctyp); - value constructor_arg_list : Gram.Entry.t Ast.ctyp; - value constructor_declaration : Gram.Entry.t Ast.ctyp; - value constructor_declarations : Gram.Entry.t Ast.ctyp; - value ctyp : Gram.Entry.t Ast.ctyp; - value ctyp_quot : Gram.Entry.t Ast.ctyp; - value cvalue_binding : Gram.Entry.t Ast.expr; - value direction_flag : Gram.Entry.t Ast.direction_flag; - value direction_flag_quot : Gram.Entry.t Ast.direction_flag; - value dummy : Gram.Entry.t unit; - value eq_expr : Gram.Entry.t (string -> Ast.patt -> Ast.patt); - value expr : Gram.Entry.t Ast.expr; - value expr_eoi : Gram.Entry.t Ast.expr; - value expr_quot : Gram.Entry.t Ast.expr; - value field_expr : Gram.Entry.t Ast.rec_binding; - value field_expr_list : Gram.Entry.t Ast.rec_binding; - value fun_binding : Gram.Entry.t Ast.expr; - value fun_def : Gram.Entry.t Ast.expr; - value ident : Gram.Entry.t Ast.ident; - value ident_quot : Gram.Entry.t Ast.ident; - value ipatt : Gram.Entry.t Ast.patt; - value ipatt_tcon : Gram.Entry.t Ast.patt; - value label : Gram.Entry.t string; - value label_declaration : Gram.Entry.t Ast.ctyp; - value label_declaration_list : Gram.Entry.t Ast.ctyp; - value label_expr : Gram.Entry.t Ast.rec_binding; - value label_expr_list : Gram.Entry.t Ast.rec_binding; - value label_ipatt : Gram.Entry.t Ast.patt; - value label_ipatt_list : Gram.Entry.t Ast.patt; - value label_longident : Gram.Entry.t Ast.ident; - value label_patt : Gram.Entry.t Ast.patt; - value label_patt_list : Gram.Entry.t Ast.patt; - value labeled_ipatt : Gram.Entry.t Ast.patt; - value let_binding : Gram.Entry.t Ast.binding; - value meth_list : Gram.Entry.t (Ast.ctyp * Ast.row_var_flag); - value meth_decl : Gram.Entry.t Ast.ctyp; - value module_binding : Gram.Entry.t Ast.module_binding; - value module_binding0 : Gram.Entry.t Ast.module_expr; - value module_binding_quot : Gram.Entry.t Ast.module_binding; - value module_declaration : Gram.Entry.t Ast.module_type; - value module_expr : Gram.Entry.t Ast.module_expr; - value module_expr_quot : Gram.Entry.t Ast.module_expr; - value module_longident : Gram.Entry.t Ast.ident; - value module_longident_with_app : Gram.Entry.t Ast.ident; - value module_rec_declaration : Gram.Entry.t Ast.module_binding; - value module_type : Gram.Entry.t Ast.module_type; - value package_type : Gram.Entry.t Ast.module_type; - value module_type_quot : Gram.Entry.t Ast.module_type; - value more_ctyp : Gram.Entry.t Ast.ctyp; - value name_tags : Gram.Entry.t Ast.ctyp; - value opt_as_lident : Gram.Entry.t string; - value opt_class_self_patt : Gram.Entry.t Ast.patt; - value opt_class_self_type : Gram.Entry.t Ast.ctyp; - value opt_comma_ctyp : Gram.Entry.t Ast.ctyp; - value opt_dot_dot : Gram.Entry.t Ast.row_var_flag; - value row_var_flag_quot : Gram.Entry.t Ast.row_var_flag; - value opt_eq_ctyp : Gram.Entry.t Ast.ctyp; - value opt_expr : Gram.Entry.t Ast.expr; - value opt_meth_list : Gram.Entry.t Ast.ctyp; - value opt_mutable : Gram.Entry.t Ast.mutable_flag; - value mutable_flag_quot : Gram.Entry.t Ast.mutable_flag; - value opt_override : Gram.Entry.t Ast.override_flag; - value override_flag_quot : Gram.Entry.t Ast.override_flag; - value opt_polyt : Gram.Entry.t Ast.ctyp; - value opt_private : Gram.Entry.t Ast.private_flag; - value private_flag_quot : Gram.Entry.t Ast.private_flag; - value opt_rec : Gram.Entry.t Ast.rec_flag; - value rec_flag_quot : Gram.Entry.t Ast.rec_flag; - value opt_virtual : Gram.Entry.t Ast.virtual_flag; - value virtual_flag_quot : Gram.Entry.t Ast.virtual_flag; - value opt_when_expr : Gram.Entry.t Ast.expr; - value patt : Gram.Entry.t Ast.patt; - value patt_as_patt_opt : Gram.Entry.t Ast.patt; - value patt_eoi : Gram.Entry.t Ast.patt; - value patt_quot : Gram.Entry.t Ast.patt; - value patt_tcon : Gram.Entry.t Ast.patt; - value phrase : Gram.Entry.t Ast.str_item; - value poly_type : Gram.Entry.t Ast.ctyp; - value row_field : Gram.Entry.t Ast.ctyp; - value sem_expr : Gram.Entry.t Ast.expr; - value sem_expr_for_list : Gram.Entry.t (Ast.expr -> Ast.expr); - value sem_patt : Gram.Entry.t Ast.patt; - value sem_patt_for_list : Gram.Entry.t (Ast.patt -> Ast.patt); - value semi : Gram.Entry.t unit; - value sequence : Gram.Entry.t Ast.expr; - value do_sequence : Gram.Entry.t Ast.expr; - value sig_item : Gram.Entry.t Ast.sig_item; - value sig_item_quot : Gram.Entry.t Ast.sig_item; - value sig_items : Gram.Entry.t Ast.sig_item; - value star_ctyp : Gram.Entry.t Ast.ctyp; - value str_item : Gram.Entry.t Ast.str_item; - value str_item_quot : Gram.Entry.t Ast.str_item; - value str_items : Gram.Entry.t Ast.str_item; - value type_constraint : Gram.Entry.t unit; - value type_declaration : Gram.Entry.t Ast.ctyp; - value type_ident_and_parameters : Gram.Entry.t (string * list Ast.ctyp); - value type_kind : Gram.Entry.t Ast.ctyp; - value type_longident : Gram.Entry.t Ast.ident; - value type_longident_and_parameters : Gram.Entry.t Ast.ctyp; - value type_parameter : Gram.Entry.t Ast.ctyp; - value type_parameters : Gram.Entry.t (Ast.ctyp -> Ast.ctyp); - value typevars : Gram.Entry.t Ast.ctyp; - value val_longident : Gram.Entry.t Ast.ident; - value value_let : Gram.Entry.t unit; - value value_val : Gram.Entry.t unit; - value with_constr : Gram.Entry.t Ast.with_constr; - value with_constr_quot : Gram.Entry.t Ast.with_constr; - value prefixop : Gram.Entry.t Ast.expr; - value infixop0 : Gram.Entry.t Ast.expr; - value infixop1 : Gram.Entry.t Ast.expr; - value infixop2 : Gram.Entry.t Ast.expr; - value infixop3 : Gram.Entry.t Ast.expr; - value infixop4 : Gram.Entry.t Ast.expr; -end; - -(** A signature for syntax extension (syntax -> syntax functors). *) -module type SyntaxExtension = functor (Syn : Syntax) - -> (Syntax with module Loc = Syn.Loc - and module Ast = Syn.Ast - and module Token = Syn.Token - and module Gram = Syn.Gram - and module Quotation = Syn.Quotation); diff --git a/camlp4/Camlp4/Struct.mlpack b/camlp4/Camlp4/Struct.mlpack deleted file mode 100644 index a939fe77..00000000 --- a/camlp4/Camlp4/Struct.mlpack +++ /dev/null @@ -1,15 +0,0 @@ -AstFilters -Camlp4Ast -Camlp4Ast2OCamlAst -CleanAst -CommentFilter -DynLoader -EmptyError -EmptyPrinter -FreeVars -Lexer -Loc -Quotation -Token -Grammar -DynAst diff --git a/camlp4/Camlp4/Struct/.ignore b/camlp4/Camlp4/Struct/.ignore deleted file mode 100644 index 262784db..00000000 --- a/camlp4/Camlp4/Struct/.ignore +++ /dev/null @@ -1,2 +0,0 @@ -Lexer.ml -Camlp4Ast.tmp.ml diff --git a/camlp4/Camlp4/Struct/AstFilters.ml b/camlp4/Camlp4/Struct/AstFilters.ml deleted file mode 100644 index 6474ba8e..00000000 --- a/camlp4/Camlp4/Struct/AstFilters.ml +++ /dev/null @@ -1,37 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Ast : Sig.Camlp4Ast) -: Sig.AstFilters with module Ast = Ast -= struct - - module Ast = Ast; - - type filter 'a = 'a -> 'a; - - value interf_filters = Queue.create (); - value fold_interf_filters f i = Queue.fold f i interf_filters; - value implem_filters = Queue.create (); - value fold_implem_filters f i = Queue.fold f i implem_filters; - value topphrase_filters = Queue.create (); - value fold_topphrase_filters f i = Queue.fold f i topphrase_filters; - - value register_sig_item_filter f = Queue.add f interf_filters; - value register_str_item_filter f = Queue.add f implem_filters; - value register_topphrase_filter f = Queue.add f topphrase_filters; -end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast deleted file mode 100644 index 9c5a9975..00000000 --- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast +++ /dev/null @@ -1,544 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Ast with module Loc = Loc -= struct - module Loc = Loc; - - module Ast = struct - include Sig.MakeCamlp4Ast Loc; - - value safe_string_escaped s = - if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s - else String.escaped s; - end; - - include Ast; - - external loc_of_ctyp : ctyp -> Loc.t = "%field0"; - external loc_of_patt : patt -> Loc.t = "%field0"; - external loc_of_expr : expr -> Loc.t = "%field0"; - external loc_of_module_type : module_type -> Loc.t = "%field0"; - external loc_of_module_expr : module_expr -> Loc.t = "%field0"; - external loc_of_sig_item : sig_item -> Loc.t = "%field0"; - external loc_of_str_item : str_item -> Loc.t = "%field0"; - external loc_of_class_type : class_type -> Loc.t = "%field0"; - external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; - external loc_of_class_expr : class_expr -> Loc.t = "%field0"; - external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; - external loc_of_with_constr : with_constr -> Loc.t = "%field0"; - external loc_of_binding : binding -> Loc.t = "%field0"; - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; - external loc_of_module_binding : module_binding -> Loc.t = "%field0"; - external loc_of_match_case : match_case -> Loc.t = "%field0"; - external loc_of_ident : ident -> Loc.t = "%field0"; - - value ghost = Loc.ghost; - - value rec is_module_longident = - fun - [ <:ident< $_$.$i$ >> -> is_module_longident i - | <:ident< $i1$ $i2$ >> -> - is_module_longident i1 && is_module_longident i2 - | <:ident< $uid:_$ >> -> True - | _ -> False ]; - - value ident_of_expr = - let error () = - invalid_arg "ident_of_expr: this expression is not an identifier" in - let rec self = - fun - [ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >> - | <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >> - | <:expr< $lid:_$ >> -> error () - | <:expr< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:expr< $id:i$ >> -> i - | <:expr< $_$ $_$ >> -> error () - | t -> self t ]; - - value ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - fun - [ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >> - | <:ctyp< $lid:_$ >> -> error () - | <:ctyp< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:ctyp< $id:i$ >> -> i - | t -> self t ]; - - value ident_of_patt = - let error () = - invalid_arg "ident_of_patt: this pattern is not an identifier" in - let rec self = - fun - [ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >> - | <:patt< $lid:_$ >> -> error () - | <:patt< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:patt< $id:i$ >> -> i - | p -> self p ]; - - value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt<>> -> True (* why not *) - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $p$ } >> -> is_irrefut_patt p - | <:patt< $_$ = $p$ >> -> is_irrefut_patt p - | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) - | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl - | <:patt< ? $_$ >> -> True - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | <:patt< lazy $p$ >> -> is_irrefut_patt p - | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) - | <:patt< (module $_$) >> -> True - | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | - <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | - <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False - ]; - - value rec is_constructor = - fun - [ <:ident< $_$.$i$ >> -> is_constructor i - | <:ident< $uid:_$ >> -> True - | <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False - | <:ident< $anti:_$ >> -> assert False ]; - - value is_patt_constructor = - fun - [ <:patt< $id:i$ >> -> is_constructor i - | <:patt< `$_$ >> -> True - | _ -> False ]; - - value rec is_expr_constructor = - fun - [ <:expr< $id:i$ >> -> is_constructor i - | <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2 - | <:expr< `$_$ >> -> True - | _ -> False ]; - - value rec tyOr_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ]; - - value rec tyAnd_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ]; - - value rec tySem_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ]; - - value rec tyCom_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ]; - - value rec tyAmp_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ]; - - value rec tySta_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ]; - - value rec stSem_of_list = - fun - [ [] -> <:str_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ]; - - value rec sgSem_of_list = - fun - [ [] -> <:sig_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ]; - - value rec biAnd_of_list = - fun - [ [] -> <:binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ]; - - value rec rbSem_of_list = - fun - [ [] -> <:rec_binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_rec_binding b in - <:rec_binding< $b$; $rbSem_of_list bs$ >> ]; - - value rec wcAnd_of_list = - fun - [ [] -> <:with_constr@ghost<>> - | [w] -> w - | [w::ws] -> - let _loc = loc_of_with_constr w in - <:with_constr< $w$ and $wcAnd_of_list ws$ >> ]; - - value rec idAcc_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ . $idAcc_of_list is$ >> ]; - - value rec idApp_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ $idApp_of_list is$ >> ]; - - value rec mcOr_of_list = - fun - [ [] -> <:match_case@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_match_case x in - <:match_case< $x$ | $mcOr_of_list xs$ >> ]; - - value rec mbAnd_of_list = - fun - [ [] -> <:module_binding@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_binding x in - <:module_binding< $x$ and $mbAnd_of_list xs$ >> ]; - - value rec meApp_of_list = - fun - [ [] -> assert False - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_expr x in - <:module_expr< $x$ $meApp_of_list xs$ >> ]; - - value rec ceAnd_of_list = - fun - [ [] -> <:class_expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_expr x in - <:class_expr< $x$ and $ceAnd_of_list xs$ >> ]; - - value rec ctAnd_of_list = - fun - [ [] -> <:class_type@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_type x in - <:class_type< $x$ and $ctAnd_of_list xs$ >> ]; - - value rec cgSem_of_list = - fun - [ [] -> <:class_sig_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_sig_item x in - <:class_sig_item< $x$; $cgSem_of_list xs$ >> ]; - - value rec crSem_of_list = - fun - [ [] -> <:class_str_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_str_item x in - <:class_str_item< $x$; $crSem_of_list xs$ >> ]; - - value rec paSem_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$; $paSem_of_list xs$ >> ]; - - value rec paCom_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$, $paCom_of_list xs$ >> ]; - - value rec exSem_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$; $exSem_of_list xs$ >> ]; - - value rec exCom_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$, $exCom_of_list xs$ >> ]; - - value ty_of_stl = - fun - [ (_loc, s, []) -> <:ctyp< $uid:s$ >> - | (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ]; - - value ty_of_sbt = - fun - [ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >> - | (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ]; - - value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>; - value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); - value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); - value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); - - value rec pel_of_binding = - fun - [ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 - | <:binding< $p$ = $e$ >> -> [(p, e)] - | _ -> assert False ]; - - value rec list_of_binding x acc = - match x with - [ <:binding< $b1$ and $b2$ >> -> - list_of_binding b1 (list_of_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_rec_binding x acc = - match x with - [ <:rec_binding< $b1$; $b2$ >> -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_with_constr x acc = - match x with - [ <:with_constr< $w1$ and $w2$ >> -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> [t :: acc] ]; - - value rec list_of_ctyp x acc = - match x with - [ <:ctyp<>> -> acc - | <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> | - <:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> | - <:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> [x :: acc] ]; - - value rec list_of_patt x acc = - match x with - [ <:patt<>> -> acc - | <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> -> - list_of_patt x (list_of_patt y acc) - | x -> [x :: acc] ]; - - value rec list_of_expr x acc = - match x with - [ <:expr<>> -> acc - | <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> -> - list_of_expr x (list_of_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_str_item x acc = - match x with - [ <:str_item<>> -> acc - | <:str_item< $x$; $y$ >> -> - list_of_str_item x (list_of_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_sig_item x acc = - match x with - [ <:sig_item<>> -> acc - | <:sig_item< $x$; $y$ >> -> - list_of_sig_item x (list_of_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_sig_item x acc = - match x with - [ <:class_sig_item<>> -> acc - | <:class_sig_item< $x$; $y$ >> -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_str_item x acc = - match x with - [ <:class_str_item<>> -> acc - | <:class_str_item< $x$; $y$ >> -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_type x acc = - match x with - [ <:class_type< $x$ and $y$ >> -> - list_of_class_type x (list_of_class_type y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_expr x acc = - match x with - [ <:class_expr< $x$ and $y$ >> -> - list_of_class_expr x (list_of_class_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_expr x acc = - match x with - [ <:module_expr< $x$ $y$ >> -> - list_of_module_expr x (list_of_module_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_match_case x acc = - match x with - [ <:match_case<>> -> acc - | <:match_case< $x$ | $y$ >> -> - list_of_match_case x (list_of_match_case y acc) - | x -> [x :: acc] ]; - - value rec list_of_ident x acc = - match x with - [ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> -> - list_of_ident x (list_of_ident y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> [x :: acc] ]; - - module Camlp4Trash = struct - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - end; - - module Meta = struct - - module type META_LOC = sig - (** The first location is where to put the returned pattern. - Generally it's _loc to match with <:patt< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; - (** The first location is where to put the returned expression. - Generally it's _loc to match with <:expr< ... >> quotations. - The second location is the one to treat. *) - value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; - end; - - module MetaLoc = struct - value meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:patt< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:patt< True >> else <:patt< False >> $) >>; - value meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:expr< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:expr< True >> else <:expr< False >> $) >>; - end; - - module MetaGhostLoc = struct - value meta_loc_patt _loc _ = <:patt< Loc.ghost >>; - value meta_loc_expr _loc _ = <:expr< Loc.ghost >>; - end; - - module MetaLocVar = struct - value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>; - value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>; - end; - - module Make (MetaLoc : META_LOC) = struct - open MetaLoc; - - value meta_loc = meta_loc_expr; - module Expr = Camlp4Filters.MetaGeneratorExpr Ast; - value meta_loc = meta_loc_patt; - module Patt = Camlp4Filters.MetaGeneratorPatt Ast; - end; - - end; - - class map = Camlp4MapGenerator.generated; - - class fold = Camlp4FoldGenerator.generated; - - value map_expr f = object - inherit map as super; - method expr x = f (super#expr x); - end; - value map_patt f = object - inherit map as super; - method patt x = f (super#patt x); - end; - value map_ctyp f = object - inherit map as super; - method ctyp x = f (super#ctyp x); - end; - value map_str_item f = object - inherit map as super; - method str_item x = f (super#str_item x); - end; - value map_sig_item f = object - inherit map as super; - method sig_item x = f (super#sig_item x); - end; - value map_loc f = object - inherit map as super; - method loc x = f (super#loc x); - end; -end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml deleted file mode 100644 index 3c04214a..00000000 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ /dev/null @@ -1,1238 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) = struct - open Format; - open Camlp4_import.Parsetree; - open Camlp4_import.Longident; - open Camlp4_import.Asttypes; - open Ast; - - value constructors_arity () = - debug ast2pt "constructors_arity: %b@." Camlp4_config.constructors_arity.val in - Camlp4_config.constructors_arity.val; - - value error loc str = Loc.raise loc (Failure str); - - value char_of_char_token loc s = - try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value string_of_string_token loc s = - try Token.Eval.string s - with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value remove_underscores s = - let l = String.length s in - let rec remove src dst = - if src >= l then - if dst >= l then s else String.sub s 0 dst - else - match s.[src] with - [ '_' -> remove (src + 1) dst - | c -> do { s.[dst] := c; remove (src + 1) (dst + 1) } ] - in remove 0 0 - ; - - value mkloc = Loc.to_ocaml_location; - value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); - - value with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc); - - value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; - value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; - value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; - value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; - value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; - value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; - value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; - value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; - value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; - value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; - value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; - value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; }; - value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }; - - value mkpolytype t = - match t.ptyp_desc with - [ Ptyp_poly _ _ -> t - | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] - ; - - value mkvirtual = fun - [ <:virtual_flag< virtual >> -> Virtual - | <:virtual_flag<>> -> Concrete - | _ -> assert False ]; - - value mkdirection = fun - [ <:direction_flag< to >> -> Upto - | <:direction_flag< downto >> -> Downto - | _ -> assert False ]; - - value lident s = Lident s; - value lident_with_loc s loc = with_loc (Lident s) loc; - - - value ldot l s = Ldot l s; - value lapply l s = Lapply l s; - - value conv_con = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') - [("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value conv_lab = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value array_function_no_loc str name = - ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) - ; - value array_function loc str name = with_loc (array_function_no_loc str name) loc; - value mkrf = - fun - [ <:rec_flag< rec >> -> Recursive - | <:rec_flag<>> -> Nonrecursive - | _ -> assert False ]; - - value mkli sloc s list = with_loc (loop lident list) sloc - where rec loop f = - fun - [ [i :: il] -> loop (ldot (f i)) il - | [] -> f s ] - ; - - value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] - ; - - value ident_tag ?(conv_lid = fun x -> x) i = - - let rec self i acc = - match i with - [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> - (ldot (lident "*predef*") "option", `lident) - | <:ident< $i1$.$i2$ >> -> - self i2 (Some (self i1 acc)) - | <:ident< $i1$ $i2$ >> -> - let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in - let x = - match acc with - [ None -> i' - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `app) - | <:ident< $uid:s$ >> -> - let x = - match acc with - [ None -> lident s - | Some (acc, `uident | `app) -> ldot acc s - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `uident) - | <:ident< $lid:s$ >> -> - let x = - match acc with - [ None -> lident (conv_lid s) - | Some (acc, `uident | `app) -> ldot acc (conv_lid s) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `lident) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in self i None; - - value ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i); - value ident ?conv_lid i = - with_loc (ident_noloc ?conv_lid i) (loc_of_ident i); - - value long_lident msg id = - match ident_tag id with - [ (i, `lident) -> with_loc i (loc_of_ident id) - | _ -> error (loc_of_ident id) msg ] - ; - - value long_type_ident = long_lident "invalid long identifier type"; - value long_class_ident = long_lident "invalid class name"; - - value long_uident_noloc ?(conv_con = fun x -> x) i = - match ident_tag i with - [ (Ldot i s, `uident) -> ldot i (conv_con s) - | (Lident s, `uident) -> lident (conv_con s) - | (i, `app) -> i - | _ -> error (loc_of_ident i) "uppercase identifier expected" ] - ; - - value long_uident ?conv_con i = - with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i); - - value rec ctyp_long_id_prefix t = - match t with - [ <:ctyp< $id:i$ >> -> ident_noloc i - | <:ctyp< $m1$ $m2$ >> -> - let li1 = ctyp_long_id_prefix m1 in - let li2 = ctyp_long_id_prefix m2 in - Lapply li1 li2 - | t -> error (loc_of_ctyp t) "invalid module expression" ] - ; - - value ctyp_long_id t = - match t with - [ <:ctyp< $id:i$ >> -> - (False, long_type_ident i) - | TyApp loc _ _ -> - error loc "invalid type name" - | TyCls _ i -> (True, ident i) - | t -> error (loc_of_ctyp t) "invalid type" ] - ; - - value rec ty_var_list_of_ctyp = - fun - [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 - | <:ctyp< '$s$ >> -> [s] - | _ -> assert False ]; - - value predef_option loc = - TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); - - value rec ctyp = - fun - [ TyId loc i -> - let li = long_type_ident i in - mktyp loc (Ptyp_constr li []) - | TyAli loc t1 t2 -> - let (t, i) = - match (t1, t2) with - [ (t, TyQuo _ s) -> (t, s) - | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "invalid alias type" ] - in - mktyp loc (Ptyp_alias (ctyp t) i) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp loc _ _ as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) - else mktyp loc (Ptyp_constr li (List.map ctyp al)) - | TyArr loc (TyLab _ lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (predef_option loc1) t1 in - mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) - | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) - | <:ctyp@loc< < $fl$ .. > >> -> - mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) - | TyCls loc id -> - mktyp loc (Ptyp_class (ident id) [] []) - | <:ctyp@loc< (module $pt$) >> -> - let (i, cs) = package_type pt in - mktyp loc (Ptyp_package i cs) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc _ _ -> error loc "labelled type not allowed here" - | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2)) - | TyQuo loc s -> mktyp loc (Ptyp_var s) - | TyRec loc _ -> error loc "record type not allowed here" - | TySum loc _ -> error loc "sum type not allowed here" - | TyPrv loc _ -> error loc "private type not allowed here" - | TyMut loc _ -> error loc "mutable type not allowed here" - | TyOr loc _ _ -> error loc "type1 | type2 not allowed here" - | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here" - | TyOf loc _ _ -> error loc "type1 of type2 not allowed here" - | TyCol loc _ _ -> error loc "type1 : type2 not allowed here" - | TySem loc _ _ -> error loc "type1 ; type2 not allowed here" - | <:ctyp@loc< ($t1$ * $t2$) >> -> - mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) - | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True None) - | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None) - | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some [])) - | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> - mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t'))) - | TyAnt loc _ -> error loc "antiquotation not allowed here" - | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | - TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | - TyAnP _ | TyAnM _ | TyTypePol _ _ _ | - TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> - assert False ] - and row_field = fun - [ <:ctyp<>> -> [] - | <:ctyp< `$i$ >> -> [Rtag i True []] - | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))] - | <:ctyp< `$i$ of $t$ >> -> [Rtag i False (List.map ctyp (list_of_ctyp t []))] - | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2 - | t -> [Rinherit (ctyp t)] ] - and name_tags = fun - [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2 - | <:ctyp< `$s$ >> -> [s] - | _ -> assert False ] - and meth_list fl acc = - match fl with - [ <:ctyp<>> -> acc - | <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) - | <:ctyp@loc< $lid:lab$ : $t$ >> -> - [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc] - | _ -> assert False ] - - and package_type_constraints wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr< type $id:id$ = $ct$ >> -> - [(ident id, ctyp ct) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> - package_type_constraints wc1 (package_type_constraints wc2 acc) - | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] - - and package_type : module_type -> package_type = - fun - [ <:module_type< $id:i$ with $wc$ >> -> - (long_uident i, package_type_constraints wc []) - | <:module_type< $id:i$ >> -> (long_uident i, []) - | mt -> error (loc_of_module_type mt) "unexpected package type" ] - ; - - value mktype loc tl cl tk tp tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; - ptype_variance = variance} - ; - value mkprivate' m = if m then Private else Public; - value mkprivate = fun - [ <:private_flag< private >> -> Private - | <:private_flag<>> -> Public - | _ -> assert False ]; - value mktrecord = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> -> - (with_loc s sloc, Mutable, mkpolytype (ctyp t), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> -> - (with_loc s sloc, Immutable, mkpolytype (ctyp t), mkloc loc) - | _ -> assert False (*FIXME*) ]; - value mkvariant = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> - (with_loc (conv_con s) sloc, [], None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> - (with_loc (conv_con s) sloc, [], Some (ctyp t), mkloc loc) - - | _ -> assert False (*FIXME*) ]; - value rec type_decl tl cl loc m pflag = - fun - [ <:ctyp< $t1$ == $t2$ >> -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | <:ctyp@_loc< private $t$ >> -> - if pflag then - error _loc "multiple private keyword used, use only one instead" - else - type_decl tl cl loc m True t - | <:ctyp< { $t$ } >> -> - mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m - | <:ctyp< [ $t$ ] >> -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m - | t -> - if m <> None then - error loc "only one manifest type allowed by definition" else - let m = - match t with - [ <:ctyp<>> -> None - | _ -> Some (ctyp t) ] - in - mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] - ; - - value type_decl tl cl t loc = type_decl tl cl loc None False t; - - value mkvalue_desc loc t p = {pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc}; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value mkmutable = fun - [ <:mutable_flag< mutable >> -> Mutable - | <:mutable_flag<>> -> Immutable - | _ -> assert False ]; - - value paolab lab p = - match (lab, p) with - [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i - | ("", p) -> error (loc_of_patt p) "bad ast in label" - | _ -> lab ] - ; - - value opt_private_ctyp = - fun - [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) - | t -> (Ptype_abstract, Public, ctyp t) ]; - - value rec type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) - | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] - | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] - | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] - | _ -> assert False ]; - - value rec optional_type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(Some (with_loc s loc), (True, False)) :: acc] - | Ast.TyAnP _loc -> [(None, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(Some (with_loc s loc), (False, True)) :: acc] - | Ast.TyAnM _loc -> [(None, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(Some (with_loc s loc), (False, False)) :: acc] - | Ast.TyAny _loc -> [(None, (False, False)) :: acc] - | _ -> assert False ]; - - value rec class_parameters t acc = - match t with - [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(with_loc s loc, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(with_loc s loc, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(with_loc s loc, (False, False)) :: acc] - | _ -> assert False ]; - - value rec type_parameters_and_type_name t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> - type_parameters_and_type_name t1 - (optional_type_parameters t2 acc) - | <:ctyp< $id:i$ >> -> (ident i, acc) - | _ -> assert False ]; - - value mkwithtyp pwith_type loc id_tpl ct = - let (id, tpl) = type_parameters_and_type_name id_tpl [] in - let (params, variance) = List.split tpl in - let (kind, priv, ct) = opt_private_ctyp ct in - (id, pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; ptype_variance = variance}); - - value rec mkwithc wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr@loc< type $id_tpl$ = $ct$ >> -> - [mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ = $i2$ >> -> - [(long_uident i1, Pwith_module (long_uident i2)) :: acc] - | <:with_constr@loc< type $id_tpl$ := $ct$ >> -> - [mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) -> - [(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc) - | <:with_constr@loc< $anti:_$ >> -> - error loc "bad with constraint (antiquotation)" ]; - - value rec patt_fa al = - fun - [ PaApp _ f a -> patt_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec patt = - fun - [ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> -> - mkpat loc (Ppat_var (with_loc s sloc)) - | <:patt@loc< $id:i$ >> -> - let p = Ppat_construct (long_uident ~conv_con i) - None (constructors_arity ()) - in mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc) - | (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc) - | _ -> error loc "invalid alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt loc _ -> error loc "antiquotation not allowed here" - | PaAny loc -> mkpat loc Ppat_any - | <:patt@loc< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> -> - mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc) - (Some (mkpat loc_any Ppat_any)) False) - | PaApp loc _ _ as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - match (patt f).ppat_desc with - [ Ppat_construct li None _ -> - if constructors_arity () then - mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - | Ppat_variant s None -> - let a = - if constructors_arity () then - mkpat loc (Ppat_tuple al) - else - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in mkpat loc (Ppat_variant s (Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" ] - | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s))) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here" - | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) - | PaRng loc p1 p2 -> - match (p1, p2) with - [ (PaChr loc1 c1, PaChr loc2 c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in - mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" ] - | PaRec loc p -> - let ps = list_of_patt p [] in - let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in - let (wildcards,ps) = List.partition is_wildcard ps in - let is_closed = if wildcards = [] then Closed else Open in - mkpat loc (Ppat_record (List.map mklabpat ps, is_closed)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | <:patt@loc< ($p1$, $p2$) >> -> - mkpat loc (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) - | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) - | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) - | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc)) - | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> - error (loc_of_patt p) "invalid pattern" ] - and mklabpat = - fun - [ <:patt< $i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p) - | p -> error (loc_of_patt p) "invalid pattern" ]; - - value rec expr_fa al = - fun - [ ExApp _ f a -> expr_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec class_expr_fa al = - fun - [ CeApp _ ce a -> class_expr_fa [a :: al] ce - | ce -> (ce, al) ] - ; - - - value rec sep_expr_acc l = - fun - [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 - | <:expr@loc< $uid:s$ >> as e -> - match l with - [ [] -> [(loc, [], e)] - | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ] - | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> -> - let rec normalize_acc = - fun - [ <:ident@_loc< $i1$.$i2$ >> -> - <:expr< $normalize_acc i1$.$normalize_acc i2$ >> - | <:ident@_loc< $i1$ $i2$ >> -> - <:expr< $normalize_acc i1$ $normalize_acc i2$ >> - | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> | - <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ] - in sep_expr_acc l (normalize_acc i) - | e -> [(loc_of_expr e, [], e) :: l] ] - ; - - value override_flag loc = - fun [ <:override_flag< ! >> -> Override - | <:override_flag<>> -> Fresh - | _ -> error loc "antiquotation not allowed here" - ]; - - value list_of_opt_ctyp ot acc = - match ot with - [ <:ctyp<>> -> acc - | t -> list_of_ctyp t acc ]; - -value varify_constructors var_names = - let rec loop t = - let desc = - match t.ptyp_desc with - [ - Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x - | Ptyp_arrow label core_type core_type' -> - Ptyp_arrow label (loop core_type) (loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ({ txt = Lident s }) [] when List.mem s var_names -> - Ptyp_var ("&" ^ s) - | Ptyp_constr longident lst -> - Ptyp_constr longident (List.map loop lst) - | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) - | Ptyp_class longident lst lbl_list -> - Ptyp_class (longident, List.map loop lst, lbl_list) - | Ptyp_alias core_type string -> - Ptyp_alias(loop core_type, string) - | Ptyp_variant row_field_list flag lbl_lst_option -> - Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) - | Ptyp_poly string_lst core_type -> - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package longident lst -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) -] - in - {(t) with ptyp_desc = desc} - and loop_core_field t = - let desc = - match t.pfield_desc with - [ Pfield(n,typ) -> - Pfield(n,loop typ) - | Pfield_var -> - Pfield_var] - in - { (t) with pfield_desc=desc} - and loop_row_field x = - match x with - [ Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) ] - in - loop; - - - - value rec expr = - fun - [ <:expr@loc< $x$.val >> -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) [("", expr x)]) - | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] -> - let ca = constructors_arity () in - (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l) - | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] -> - (mkexp loc (Pexp_ident (mkli sloc s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast in expression" ] - in - let (_, e) = - List.fold_left - (fun (loc_bp, e1) (loc_ep, ml, e2) -> - match e2 with - [ <:expr@sloc< $lid:s$ >> -> - let loc = Loc.merge loc_bp loc_ep - in (loc, mkexp loc (Pexp_field e1 (mkli sloc (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt loc _ -> error loc "antiquotation not allowed here" - | ExApp loc _ _ as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - match (expr f).pexp_desc with - [ Pexp_construct li None _ -> - let al = List.map snd al in - if constructors_arity () then - mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - | Pexp_variant s None -> - let al = List.map snd al in - let a = - if constructors_arity () then - mkexp loc (Pexp_tuple al) - else - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in mkexp loc (Pexp_variant s (Some a)) - | _ -> mkexp loc (Pexp_apply (expr f) al) ] - | ExAre loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ <:expr@loc< $x$.val >> -> - Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre loc e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v) - | ExSte loc e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function loc "String" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | _ -> error loc "bad left part of assignment" ] - in - mkexp loc e - | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) - | ExChr loc s -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - let t1 = - match t1 with - [ <:ctyp<>> -> None - | t -> Some (ctyp t) ] in - mkexp loc (Pexp_constraint (expr e) t1 (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3)) - | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> - mkexp loc - (Pexp_function lab None - [(patt_of_lab loc lab po, when_expr e w)]) - | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)]) - | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)]) - | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a [])) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf bi e -> - mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e)) - | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) - | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil }) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel [])) - | ExRec loc lel eo -> - match lel with - [ <:rec_binding<>> -> error loc "empty record" - | _ -> - let eo = - match eo with - [ <:expr<>> -> None - | e -> Some (expr e) ] in - mkexp loc (Pexp_record (mklabexp lel []) eo) ] - | ExSeq _loc e -> - let rec loop = - fun - [ [] -> expr <:expr< () >> - | [e] -> expr e - | [e :: el] -> - let _loc = Loc.merge (loc_of_expr e) _loc in - mkexp _loc (Pexp_sequence (expr e) (loop el)) ] - in - loop (list_of_expr e []) - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) - | <:expr@loc< ($e1$, $e2$) >> -> - mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) - | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | <:expr@loc< () >> -> - mkexp loc (Pexp_construct (lident_with_loc "()" loc) None True) - | <:expr@loc< $lid:s$ >> -> - mkexp loc (Pexp_ident (lident_with_loc s loc)) - | <:expr@loc< $uid:s$ >> -> - (* let ca = constructors_arity () in *) - mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open Fresh (long_uident i) (expr e)) - | <:expr@loc< (module $me$ : $pt$) >> -> - mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), - Some (mktyp loc (Ptyp_package (package_type pt))), None)) - | <:expr@loc< (module $me$) >> -> - mkexp loc (Pexp_pack (module_expr me)) - | ExFUN loc i e -> - mkexp loc (Pexp_newtype i (expr e)) - | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" - | <:expr@loc< $_$;$_$ >> -> - error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" - | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ] - and patt_of_lab _loc lab = - fun - [ <:patt<>> -> patt <:patt< $lid:lab$ >> - | p -> patt p ] - and expr_of_lab _loc lab = - fun - [ <:expr<>> -> expr <:expr< $lid:lab$ >> - | e -> expr e ] - and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr_of_lab loc lab eo) - | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo) - | e -> ("", expr e) ] - and binding x acc = - match x with - [ <:binding< $x$ and $y$ >> -> - binding x (binding y acc) - | <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> -> - (* this code is not pretty because it is temporary *) - let rec id_to_string x = - match x with - [ <:ctyp< $lid:x$ >> -> [x] - | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) - | _ -> assert False] - in - let vars = id_to_string vs in - let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let ty' = varify_constructors vars (ctyp ty) in - let mkexp = mkexp _loc in - let mkpat = mkpat _loc in - let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in - let rec mk_newtypes x = - match x with - [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) - | [newtype :: newtypes] -> - mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) - | [] -> assert False] - in - let pat = - mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)), - mktyp _loc (Ptyp_poly ampersand_vars ty'))) - in - let e = mk_newtypes vars in - [( pat, e) :: acc] - | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> - [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc] - | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc] - | <:binding<>> -> acc - | _ -> assert False ] - and match_case x acc = - match x with - [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc) - | <:match_case< $pat:p$ when $w$ -> $e$ >> -> - [(patt p, when_expr e w) :: acc] - | <:match_case<>> -> acc - | _ -> assert False ] - and when_expr e w = - match w with - [ <:expr<>> -> expr e - | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ] - and mklabexp x acc = - match x with - [ <:rec_binding< $x$; $y$ >> -> - mklabexp x (mklabexp y acc) - | <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] - | _ -> assert False ] - and mkideexp x acc = - match x with - [ <:rec_binding<>> -> acc - | <:rec_binding< $x$; $y$ >> -> - mkideexp x (mkideexp y acc) - | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc] - | _ -> assert False ] - and mktype_decl x acc = - match x with - [ <:ctyp< $x$ and $y$ >> -> - mktype_decl x (mktype_decl y acc) - | Ast.TyDcl cloc c tl td cl -> - let cl = - List.map - (fun (t1, t2) -> - let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - [(with_loc c cloc, - type_decl (List.fold_right optional_type_parameters tl []) cl td cloc) :: acc] - | _ -> assert False ] - and module_type = - fun - [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" - | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) - | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> - mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt)) - | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" - | <:module_type@loc< sig $sl$ end >> -> - mkmty loc (Pmty_signature (sig_item sl [])) - | <:module_type@loc< $mt$ with $wc$ >> -> - mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) - | <:module_type@loc< module type of $me$ >> -> - mkmty loc (Pmty_typeof (module_expr me)) - | <:module_type< $anti:_$ >> -> assert False ] - and sig_item s l = - match s with - [ <:sig_item<>> -> l - | SgCls loc cd -> - [mksig loc (Psig_class - (List.map class_info_class_type (list_of_class_type cd []))) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) - | SgDir _ _ _ -> l - | <:sig_item@loc< exception $uid:s$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) []) :: l] - | <:sig_item@loc< exception $uid:s$ of $t$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l] - | SgExc _ _ -> assert False (*FIXME*) - | SgExt loc n t sl -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module (with_loc n loc) (module_type mt)) :: l] - | SgRecMod loc mb -> - [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype (with_loc n loc) si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open Fresh (long_uident id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] - | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] - | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] - and module_sig_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_sig_binding x (module_sig_binding y acc) - | <:module_binding@loc< $s$ : $mt$ >> -> - [(with_loc s loc, module_type mt) :: acc] - | _ -> assert False ] - and module_str_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_str_binding x (module_str_binding y acc) - | <:module_binding@loc< $s$ : $mt$ = $me$ >> -> - [(with_loc s loc, module_type mt, module_expr me) :: acc] - | _ -> assert False ] - and module_expr = - fun - [ <:module_expr@loc<>> -> error loc "nil module expression" - | <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i)) - | <:module_expr@loc< $me1$ $me2$ >> -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> - mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me)) - | <:module_expr@loc< struct $sl$ end >> -> - mkmod loc (Pmod_structure (str_item sl [])) - | <:module_expr@loc< ($me$ : $mt$) >> -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | <:module_expr@loc< (value $e$ : $pt$) >> -> - mkmod loc (Pmod_unpack ( - mkexp loc (Pexp_constraint (expr e, - Some (mktyp loc (Ptyp_package (package_type pt))), - None)))) - | <:module_expr@loc< (value $e$) >> -> - mkmod loc (Pmod_unpack (expr e)) - | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] - and str_item s l = - match s with - [ <:str_item<>> -> l - | StCls loc cd -> - [mkstr loc (Pstr_class - (List.map class_info_class_expr (list_of_class_expr cd []))) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) - | StDir _ _ _ -> l - | <:str_item@loc< exception $uid:s$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) []) :: l ] - | <:str_item@loc< exception $uid:s$ of $t$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l ] - | <:str_item@loc< exception $uid:s$ = $i$ >> -> - [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (long_uident ~conv_con i)) :: l ] - | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> - error loc "type in exception alias" - | StExc _ _ _ -> assert False (*FIXME*) - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l] - | StRecMod loc mb -> - [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open Fresh (long_uident id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] - | StVal loc rf bi -> - [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] - | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] - and class_type = - fun - [ CtCon loc ViNil id tl -> - mkcty loc - (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (predef_option loc1) t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ <:ctyp<>> -> <:ctyp@loc< _ >> - | t -> t ] - in - let cil = class_sig_item ctfl [] in - mkcty loc (Pcty_signature { - pcsig_self = ctyp t; - pcsig_fields = cil; - pcsig_loc = mkloc loc; - }) - | CtCon loc _ _ _ -> - error loc "invalid virtual class inside a class type" - | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> - assert False ] - - and class_info_class_expr ci = - match ci with - [ CeEq _ (CeCon loc vir (IdLid nloc name) params) ce -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_expr ce; - pci_loc = mkloc loc; - pci_variance = variance} - | ce -> error (loc_of_class_expr ce) "bad class definition" ] - and class_info_class_type ci = - match ci with - [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct | - CtCol _ (CtCon loc vir (IdLid nloc name) params) ct -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_type ct; - pci_loc = mkloc loc; - pci_variance = variance} - | ct -> error (loc_of_class_type ct) - "bad class/class type declaration/definition" ] - and class_sig_item c l = - match c with - [ <:class_sig_item<>> -> l - | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l] - | <:class_sig_item< $csg1$; $csg2$ >> -> - class_sig_item csg1 (class_sig_item csg2 l) - | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l] - | CgMth loc s pf t -> - [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CgVal loc s b v t -> - [mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l] - | CgVir loc s b t -> - [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l] - | CgAnt _ _ -> assert False ] - and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc ViNil id tl -> - mkcl loc - (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CeFun loc (PaLab _ lab po) ce -> - mkcl loc - (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) - | CeFun loc (PaOlbi _ lab p e) ce -> - let lab = paolab lab p in - mkcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) - | CeFun loc (PaOlb _ lab p) ce -> - let lab = paolab lab p in - mkcl loc - (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) - | CeFun loc p ce -> mkcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf bi ce -> - mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkcl loc (Pcl_structure { - pcstr_pat = patt p; - pcstr_fields = cil; - }) - | CeTyc loc ce ct -> - mkcl loc (Pcl_constraint (class_expr ce) (class_type ct)) - | CeCon loc _ _ _ -> - error loc "invalid virtual class inside a class expression" - | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] - and class_str_item c l = - match c with - [ CrNil _ -> l - | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l] - | <:class_str_item< $cst1$; $cst2$ >> -> - class_str_item cst1 (class_str_item cst2 l) - | CrInh loc ov ce pb -> - let opb = if pb = "" then None else Some pb in - [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l] - | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l] - | CrMth loc s ov pf e t -> - let t = - match t with - [ <:ctyp<>> -> None - | t -> Some (mkpolytype (ctyp t)) ] in - let e = mkexp loc (Pexp_poly (expr e) t) in - [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l] - | CrVal loc s ov mf e -> - [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l] - | CrVir loc s pf t -> - [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CrVvr loc s mf t -> - [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l] - | CrAnt _ _ -> assert False ]; - - value sig_item ast = sig_item ast []; - value str_item ast = str_item ast []; - - value directive = - fun - [ <:expr<>> -> Pdir_none - | ExStr _ s -> Pdir_string s - | ExInt _ i -> Pdir_int (int_of_string i) - | <:expr< True >> -> Pdir_bool True - | <:expr< False >> -> Pdir_bool False - | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ] - ; - - value phrase = - fun - [ StDir _ d dp -> Ptop_dir d (directive dp) - | si -> Ptop_def (str_item si) ] - ; -end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli deleted file mode 100644 index 0e6f52cc..00000000 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Camlp4Ast : Sig.Camlp4Ast) : sig - open Camlp4Ast; - - (** {6 Useful functions} *) - - value sig_item : sig_item -> Camlp4_import.Parsetree.signature; - value str_item : str_item -> Camlp4_import.Parsetree.structure; - value phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase; - -end; diff --git a/camlp4/Camlp4/Struct/CleanAst.ml b/camlp4/Camlp4/Struct/CleanAst.ml deleted file mode 100644 index 8354d1c2..00000000 --- a/camlp4/Camlp4/Struct/CleanAst.ml +++ /dev/null @@ -1,145 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -(** This module is suppose to contain nils elimination. *) -module Make (Ast : Sig.Camlp4Ast) = struct - - class clean_ast = object - - inherit Ast.map as super; - - method with_constr wc = - match super#with_constr wc with - [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | - <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc - | wc -> wc ]; - - method expr e = - match super#expr e with - [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | - <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | - <:expr< $ <:expr<>> $, $e$ >> | - <:expr< $e$, $ <:expr<>> $ >> | - <:expr< $ <:expr<>> $; $e$ >> | - <:expr< $e$; $ <:expr<>> $ >> -> e - | e -> e ]; - - method patt p = - match super#patt p with - [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | - <:patt< $ <:patt<>> $ | $p$ >> | - <:patt< $p$ | $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $, $p$ >> | - <:patt< $p$, $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $; $p$ >> | - <:patt< $p$; $ <:patt<>> $ >> -> p - | p -> p ]; - - method match_case mc = - match super#match_case mc with - [ <:match_case< $ <:match_case<>> $ | $mc$ >> | - <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc - | mc -> mc ]; - - method binding bi = - match super#binding bi with - [ <:binding< $ <:binding<>> $ and $bi$ >> | - <:binding< $bi$ and $ <:binding<>> $ >> -> bi - | bi -> bi ]; - - method rec_binding rb = - match super#rec_binding rb with - [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | - <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi - | bi -> bi ]; - - method module_binding mb = - match super#module_binding mb with - [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | - <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb - | mb -> mb ]; - - method ctyp t = - match super#ctyp t with - [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | - <:ctyp< $ <:ctyp<>> $ as $t$ >> | - <:ctyp< $t$ as $ <:ctyp<>> $ >> | - <:ctyp< $t$ -> $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ -> $t$ >> | - <:ctyp< $ <:ctyp<>> $ | $t$ >> | - <:ctyp< $t$ | $ <:ctyp<>> $ >> | - <:ctyp< $t$ of $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ and $t$ >> | - <:ctyp< $t$ and $ <:ctyp<>> $ >> | - <:ctyp< $t$; $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $; $t$ >> | - <:ctyp< $ <:ctyp<>> $, $t$ >> | - <:ctyp< $t$, $ <:ctyp<>> $ >> | - <:ctyp< $t$ & $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ & $t$ >> | - <:ctyp< $ <:ctyp<>> $ * $t$ >> | - <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t - | t -> t ]; - - method sig_item sg = - match super#sig_item sg with - [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | - <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg - | <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>> - | sg -> sg ]; - - method str_item st = - match super#str_item st with - [ <:str_item< $ <:str_item<>> $; $st$ >> | - <:str_item< $st$; $ <:str_item<>> $ >> -> st - | <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>> - | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>> - | st -> st ]; - - method module_type mt = - match super#module_type mt with - [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt - | mt -> mt ]; - - method class_expr ce = - match super#class_expr ce with - [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | - <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce - | ce -> ce ]; - - method class_type ct = - match super#class_type ct with - [ <:class_type< $ <:class_type<>> $ and $ct$ >> | - <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct - | ct -> ct ]; - - method class_sig_item csg = - match super#class_sig_item csg with - [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | - <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg - | csg -> csg ]; - - method class_str_item cst = - match super#class_str_item cst with - [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | - <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst - | cst -> cst ]; - - end; - -end; diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml deleted file mode 100644 index f8cb3004..00000000 --- a/camlp4/Camlp4/Struct/CommentFilter.ml +++ /dev/null @@ -1,56 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) = struct - open Token; - - type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t)); - - value mk () = - let q = Queue.create () in - let f _ = - debug comments "take...@\n" in - try Some (Queue.take q) with [ Queue.Empty -> None ] - in (Stream.from f, q); - - value filter (_, q) = - let rec self = - parser - [ [: ` (Sig.COMMENT x, loc); xs :] -> - do { Queue.add (x, loc) q; - debug comments "add: %S at %a@\n" x Loc.dump loc in - self xs } - | [: ` x; xs :] -> - (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) - [: ` x; self xs :] - | [: :] -> [: :] ] - in self; - - value take_list (_, q) = - let rec self accu = - if Queue.is_empty q then accu else self [Queue.take q :: accu] - in self []; - - value take_stream = fst; - - value define token_fiter comments_strm = - debug comments "Define a comment filter@\n" in - Token.Filter.define_filter token_fiter - (fun previous strm -> previous (filter comments_strm strm)); - -end; diff --git a/camlp4/Camlp4/Struct/CommentFilter.mli b/camlp4/Camlp4/Struct/CommentFilter.mli deleted file mode 100644 index 1df29f7b..00000000 --- a/camlp4/Camlp4/Struct/CommentFilter.mli +++ /dev/null @@ -1,33 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) : sig - open Token; - - type t; - - value mk : unit -> t; - - value define : Token.Filter.t -> t -> unit; - - value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t); - - value take_list : t -> list (string * Loc.t); - - value take_stream : t -> Stream.t (string * Loc.t); -end; diff --git a/camlp4/Camlp4/Struct/DynAst.ml b/camlp4/Camlp4/Struct/DynAst.ml deleted file mode 100644 index 4bc8a33b..00000000 --- a/camlp4/Camlp4/Struct/DynAst.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct - module Ast = Ast; - type tag 'a = - [ Tag_ctyp - | Tag_patt - | Tag_expr - | Tag_module_type - | Tag_sig_item - | Tag_with_constr - | Tag_module_expr - | Tag_str_item - | Tag_class_type - | Tag_class_sig_item - | Tag_class_expr - | Tag_class_str_item - | Tag_match_case - | Tag_ident - | Tag_binding - | Tag_rec_binding - | Tag_module_binding ]; - - value string_of_tag = - fun - [ Tag_ctyp -> "ctyp" - | Tag_patt -> "patt" - | Tag_expr -> "expr" - | Tag_module_type -> "module_type" - | Tag_sig_item -> "sig_item" - | Tag_with_constr -> "with_constr" - | Tag_module_expr -> "module_expr" - | Tag_str_item -> "str_item" - | Tag_class_type -> "class_type" - | Tag_class_sig_item -> "class_sig_item" - | Tag_class_expr -> "class_expr" - | Tag_class_str_item -> "class_str_item" - | Tag_match_case -> "match_case" - | Tag_ident -> "ident" - | Tag_binding -> "binding" - | Tag_rec_binding -> "rec_binding" - | Tag_module_binding -> "module_binding" ]; - - value ctyp_tag = Tag_ctyp; - value patt_tag = Tag_patt; - value expr_tag = Tag_expr; - value module_type_tag = Tag_module_type; - value sig_item_tag = Tag_sig_item; - value with_constr_tag = Tag_with_constr; - value module_expr_tag = Tag_module_expr; - value str_item_tag = Tag_str_item; - value class_type_tag = Tag_class_type; - value class_sig_item_tag = Tag_class_sig_item; - value class_expr_tag = Tag_class_expr; - value class_str_item_tag = Tag_class_str_item; - value match_case_tag = Tag_match_case; - value ident_tag = Tag_ident; - value binding_tag = Tag_binding; - value rec_binding_tag = Tag_rec_binding; - value module_binding_tag = Tag_module_binding; - - type dyn; - external dyn_tag : tag 'a -> tag dyn = "%identity"; - - module Pack(X : sig type t 'a; end) = struct - (* These Obj.* hacks should be avoided with GADTs *) - type pack = (tag dyn * Obj.t); - exception Pack_error; - value pack tag v = (dyn_tag tag, Obj.repr v); - value unpack (tag : tag 'a) (tag', obj) = - if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error; - value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag); - end; -end; diff --git a/camlp4/Camlp4/Struct/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml deleted file mode 100644 index 00ab05ab..00000000 --- a/camlp4/Camlp4/Struct/DynLoader.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2001-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - - -type t = Queue.t string; - -exception Error of string and string; - -value include_dir x y = Queue.add y x; - -value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x; - -value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () = - let q = Queue.create () in do { - if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); - if camlp4_stdlib then do { - include_dir q Camlp4_config.camlp4_standard_library; - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters"); - } else (); - include_dir q "."; - q -}; - -(* Load files in core *) - -value find_in_path x name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let res = - fold_load_path x - (fun dir -> - fun - [ None -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else None - | x -> x ]) None - in match res with [ None -> raise Not_found | Some x -> x ]; - -value load = - let _initialized = ref False in - fun _path file -> - do { - if not _initialized.val then - try do { - Dynlink.init (); - Dynlink.allow_unsafe_modules True; - _initialized.val := True - } - with - [ Dynlink.Error e -> - raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ] - else (); - let fname = - try find_in_path _path file with - [ Not_found -> raise (Error file "file not found in path") ] - in - try Dynlink.loadfile fname with - [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] - }; - - -value is_native = Dynlink.is_native; diff --git a/camlp4/Camlp4/Struct/DynLoader.mli b/camlp4/Camlp4/Struct/DynLoader.mli deleted file mode 100644 index 7a7dc899..00000000 --- a/camlp4/Camlp4/Struct/DynLoader.mli +++ /dev/null @@ -1,20 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -include Sig.DynLoader; diff --git a/camlp4/Camlp4/Struct/EmptyError.ml b/camlp4/Camlp4/Struct/EmptyError.ml deleted file mode 100644 index 52a50289..00000000 --- a/camlp4/Camlp4/Struct/EmptyError.ml +++ /dev/null @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type t = unit; -exception E of t; -value print _ = assert False; -value to_string _ = assert False; diff --git a/camlp4/Camlp4/Struct/EmptyError.mli b/camlp4/Camlp4/Struct/EmptyError.mli deleted file mode 100644 index 076ee317..00000000 --- a/camlp4/Camlp4/Struct/EmptyError.mli +++ /dev/null @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Error; diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.ml b/camlp4/Camlp4/Struct/EmptyPrinter.ml deleted file mode 100644 index 11a93cd6..00000000 --- a/camlp4/Camlp4/Struct/EmptyPrinter.ml +++ /dev/null @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) = struct - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.mli b/camlp4/Camlp4/Struct/EmptyPrinter.mli deleted file mode 100644 index 94585b32..00000000 --- a/camlp4/Camlp4/Struct/EmptyPrinter.mli +++ /dev/null @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S; diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml deleted file mode 100644 index 8c253ff5..00000000 --- a/camlp4/Camlp4/Struct/FreeVars.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) = struct - - module S = Set.Make String; - - class c_fold_pattern_vars ['accu] f init = - object - inherit Ast.fold as super; - value acc = init; - method acc : 'accu = acc; - method patt = - fun - [ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> -> - {< acc = f s acc >} - | p -> super#patt p ]; - end; - - value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; - - value rec fold_binding_vars f bi acc = - match bi with - [ <:binding< $bi1$ and $bi2$ >> -> - fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) - | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc - | <:binding<>> -> acc - | <:binding< $anti:_$ >> -> assert False ]; - - class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = - object (o) - inherit Ast.fold as super; - value free : 'accu = free_init; - value env : S.t = env_init; - - method free = free; - method set_env env = {< env = env >}; - method add_atom s = {< env = S.add s env >}; - method add_patt p = {< env = fold_pattern_vars S.add p env >}; - method add_binding bi = {< env = fold_binding_vars S.add bi env >}; - - method expr = - fun - [ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> -> - if S.mem s env then o else {< free = f s free >} - - | <:expr< let $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#set_env env)#binding bi - - | <:expr< let rec $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#binding bi)#set_env env - - | <:expr< for $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> - ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env - - | <:expr< $id:_$ >> | <:expr< new $_$ >> -> o - - | <:expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - - | e -> super#expr e ]; - - method match_case = - fun - [ <:match_case< $p$ when $e1$ -> $e2$ >> -> - (((o#add_patt p)#expr e1)#expr e2)#set_env env - | m -> super#match_case m ]; - - method str_item = - fun - [ <:str_item< external $s$ : $t$ = $_$ >> -> - (o#ctyp t)#add_atom s - | <:str_item< value $bi$ >> -> - (o#binding bi)#add_binding bi - | <:str_item< value rec $bi$ >> -> - (o#add_binding bi)#binding bi - | st -> super#str_item st ]; - - method class_expr = - fun - [ <:class_expr< fun $p$ -> $ce$ >> -> - ((o#add_patt p)#class_expr ce)#set_env env - | <:class_expr< let $bi$ in $ce$ >> -> - (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env - | <:class_expr< let rec $bi$ in $ce$ >> -> - (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env - | <:class_expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - | ce -> super#class_expr ce ]; - - method class_str_item = - fun - [ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst - | <:class_str_item< inherit $override:_$ $ce$ as $s$ >> -> - (o#class_expr ce)#add_atom s - | <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> -> - (o#expr e)#add_atom s - | <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> -> - (o#ctyp t)#add_atom s - | cst -> super#class_str_item cst ]; - - method module_expr = fun - [ <:module_expr< struct $st$ end >> -> - (o#str_item st)#set_env env - | me -> super#module_expr me ]; - - end; - - value free_vars env_init e = - let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; -end; diff --git a/camlp4/Camlp4/Struct/FreeVars.mli b/camlp4/Camlp4/Struct/FreeVars.mli deleted file mode 100644 index 06d3cc0a..00000000 --- a/camlp4/Camlp4/Struct/FreeVars.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) : sig - module S : Set.S with type elt = string; - - value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu; - - class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] -> - object - inherit Ast.fold; - value acc : 'accu; - method acc : 'accu; - end; - - value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu; - - class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] -> - object ('self_type) - inherit Ast.fold; - value free : 'accu; - value env : S.t; - method free : 'accu; - method set_env : S.t -> 'self_type; - method add_atom : string -> 'self_type; - method add_patt : Ast.patt -> 'self_type; - method add_binding : Ast.binding -> 'self_type; - end; - - value free_vars : S.t -> Ast.expr -> S.t; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar.mlpack b/camlp4/Camlp4/Struct/Grammar.mlpack deleted file mode 100644 index 46fb34f7..00000000 --- a/camlp4/Camlp4/Struct/Grammar.mlpack +++ /dev/null @@ -1,13 +0,0 @@ -Delete -Dynamic -Entry -Failed -Find -Fold -Insert -Parser -Print -Search -Static -Structure -Tools diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml deleted file mode 100644 index 4273ebeb..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Delete.ml +++ /dev/null @@ -1,187 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -exception Rule_not_found of (string * string); - -let () = - Printexc.register_printer - (fun - [ Rule_not_found (symbols, entry) -> - let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in - Some msg - | _ -> None ]) in () -; - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - module Print = Print.Make Structure; - open Structure; - -value raise_rule_not_found entry symbols = - let to_string f x = - let buff = Buffer.create 128 in - let ppf = Format.formatter_of_buffer buff in - do { - f ppf x; - Format.pp_print_flush ppf (); - Buffer.contents buff - } in - let entry = to_string Print.entry entry in - let symbols = to_string Print.print_rule symbols in - raise (Rule_not_found (symbols, entry)) -; - -(* Deleting a rule *) - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -value delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - [ ([s :: sl], Node n) -> - if Tools.logically_eq_symbols entry s n.node then delete_son sl n - else - match delete_in_tree symbols n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([_ :: _], _) -> None - | ([], Node n) -> - match delete_in_tree [] n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([], DeadEnd) -> None - | ([], LocAct _ []) -> Some (Some [], DeadEnd) - | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] - and delete_son sl n = - match delete_in_tree sl n.son with - [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some [n.node :: dsl], t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None ] - in - delete_in_tree -; -value rec decr_keyw_use gram = - fun - [ Skeyword kwd -> removing gram kwd - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s - | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ] -and decr_keyw_use_in_tree gram = - fun - [ DeadEnd | LocAct _ _ -> () - | Node n -> - do { - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother - } ] -; -value rec delete_rule_in_suffix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lsuffix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_suffix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_prefix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lprefix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; - lsuffix = lev.lsuffix; lprefix = t} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_prefix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_level_list entry symbols levs = - match symbols with - [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs - | [Snterm e :: symbols] when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs ] -; - - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml deleted file mode 100644 index 06ac28f1..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml +++ /dev/null @@ -1,73 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Dynamic with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Entry = Entry.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value mk () = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - value get_filter g = g.gfilter; - - value lex g loc cs = g.glexer loc cs; - - value lex_string g loc str = lex g loc (Stream.of_string str); - - value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry.egram loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - let t = - List.fold_left - (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) - DeadEnd rl - in - Stree t; - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Entry.ml b/camlp4/Camlp4/Struct/Grammar/Entry.ml deleted file mode 100644 index 4ab0c896..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Entry.ml +++ /dev/null @@ -1,92 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Dump = Print.MakeDump Structure; - module Print = Print.Make Structure; - module Tools = Tools.Make Structure; - open Format; - open Structure; - open Tools; - - type t 'a = internal_entry; - - value name e = e.ename; - - value print ppf e = fprintf ppf "%a@\n" Print.entry e; - value dump ppf e = fprintf ppf "%a@\n" Dump.entry e; - - (* value find e s = Find.entry e s; *) - - value mk g n = - { egram = g; - ename = n; - estart = empty_entry n; - econtinue _ _ _ = parser []; - edesc = Dlevels [] }; - - value action_parse entry ts : Action.t = - try entry.estart 0 ts with - [ Stream.Failure -> - Loc.raise (get_prev_loc ts) - (Stream.Error ("illegal begin of " ^ entry.ename)) - | Loc.Exc_located _ _ as exc -> raise exc - | exc -> Loc.raise (get_prev_loc ts) exc ]; - - value lex entry loc cs = entry.egram.glexer loc cs; - - value lex_string entry loc str = lex entry loc (Stream.of_string str); - - value filter entry ts = - keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts); - - value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts); - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry loc str); - - value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a = - let f ts = Action.mk (p ts) in - { egram = g; - ename = n; - estart _ = f; - econtinue _ _ _ = parser []; - edesc = Dparser f }; - - value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) = - let f ts = Action.mk (p ts) in do { - e.estart := fun _ -> f; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dparser f - }; - - value clear e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dlevels [] - }; - - value obj x = x; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Failed.ml b/camlp4/Camlp4/Struct/Grammar/Failed.ml deleted file mode 100644 index a0327b15..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Failed.ml +++ /dev/null @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Search = Search.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Format; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken (_, descr) -> descr - | Skeyword kwd -> "\"" ^ kwd ^ "\"" - | _ -> "???" ] -; - - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s | Slist0sep s _ | - Slist1 s | Slist1sep s _ | - Sopt s | Stry s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s ] -and name_of_tree_failed entry = - fun - [ Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let txt = name_of_symbol_failed entry s in - let txt = - match (s, son) with - [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt ] - in - let txt = - match bro with - [ DeadEnd | LocAct _ _ -> txt - | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | Some (tokl, _, _) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " then ") ^ - match tok with - [ Stoken (_, descr) -> descr - | Skeyword kwd -> kwd - | _ -> assert False ]) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; -value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x; -value tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist0sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Slist1sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if entry.egram.error_verbose.val then do { - let tree = Search.tree_in_entry prev_symb tree entry.edesc; - let ppf = err_formatter; - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - Print.print_level ppf pp_force_newline (Print.flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - } - else (); - txt ^ " (in [" ^ entry.ename ^ "])" - } -; -value symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in - tree_failed entry prev_symb_result prev_symb tree -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Find.ml b/camlp4/Camlp4/Struct/Grammar/Find.ml deleted file mode 100644 index 82bd2f0e..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Find.ml +++ /dev/null @@ -1,68 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* - value entry e s = - let rec find_levels = - fun - [ [] -> None - | [lev :: levs] -> - match find_tree lev.lsuffix with - [ None -> - match find_tree lev.lprefix with - [ None -> find_levels levs - | x -> x ] - | x -> x ] ] - and symbol = - fun - [ Snterm e -> if e.ename = s then Some e else None - | Snterml e _ -> if e.ename = s then Some e else None - | Smeta _ sl _ -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep s _ -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep s _ -> find_symbol s - | Sopt s -> find_symbol s - | Stree t -> find_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> None ] - and symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and tree = - fun - [ Node {node = s; brother = bro; son = son} -> - match find_symbol s with - [ None -> - match find_tree bro with - [ None -> find_tree son - | x -> x ] - | x -> x ] - | LocAct _ _ | DeadEnd -> None ] - in - match e.edesc with - [ Dlevels levs -> - match find_levels levs with - [ Some e -> e - | None -> raise Not_found ] - | Dparser _ -> raise Not_found ] - ; -*) diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.ml b/camlp4/Camlp4/Struct/Grammar/Fold.ml deleted file mode 100644 index 99e09550..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Fold.ml +++ /dev/null @@ -1,95 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - module Parse = Parser.Make Structure; - module Fail = Failed.Make Structure; - open Sig.Grammar; - - (* Prevent from implict usage. *) - module Stream = struct - type t 'a = Stream.t 'a; - exception Failure = Stream.Failure; - exception Error = Stream.Error; - end; - - value sfold0 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> a - ; - - value sfold1 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; a = fold (f a e) :] -> a - ; - - value sfold0sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> kont (f a e) s - | [: :] -> e ] - ; - - value sfold1sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *) - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: () = psep; - a = - parser - [ [: a = psymb :] -> a - | [: a = parse_top symbl :] -> Obj.magic a - | [: :] -> raise (Stream.Error (failed symbl)) ]; - s :] -> - kont (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; s :] -> kont (f a e) s - ; -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.mli b/camlp4/Camlp4/Struct/Grammar/Fold.mli deleted file mode 100644 index 1578ccbd..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Fold.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml deleted file mode 100644 index 24deb01f..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Insert.ml +++ /dev/null @@ -1,323 +0,0 @@ -(* -*- camlp4r -*- *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - open Structure; - open Format; - open Sig.Grammar; - - value is_before s1 s2 = - match (s1, s2) with - [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False - | (Skeyword _ | Stoken _, _) -> True - | _ -> False ] - ; - value rec derive_eps = - fun - [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True - | Stry s -> derive_eps s - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ -> - (* For sure we cannot derive epsilon from these *) - False - | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself -> - (* Approximation *) - False ] - and tree_derive_eps = - fun - [ LocAct _ _ -> True - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> False ] - ; - - value empty_lev lname assoc = - let assoc = - match assoc with - [ Some a -> a - | None -> LeftA ] - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} - ; - value change_lev entry lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && entry.egram.warning_verbose.val then do { - eprintf " Changing associativity of level \"%s\"\n" n; - flush Pervasives.stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && entry.egram.warning_verbose.val then do { - eprintf " Level label \"%s\" ignored\n" n; flush Pervasives.stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } - ; - value change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] - ; - - - value get_level entry position levs = - match position with - [ Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (Before n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs]) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (After n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([lev], empty_lev, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | None -> - match levs with - [ [lev :: levs] -> ([], change_lev entry lev "", levs) - | [] -> ([], empty_lev, []) ] ] - ; - - value rec check_gram entry = - fun - [ Snterm e -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Snterml e _ -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Smeta _ sl _ -> List.iter (check_gram entry) sl - | Slist0sep s t -> do { check_gram entry t; check_gram entry s } - | Slist1sep s t -> do { check_gram entry t; check_gram entry s } - | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ | Skeyword _ -> () ] - and tree_check_gram entry = - fun - [ Node {node = n; brother = bro; son = son} -> - do { - check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son - } - | LocAct _ _ | DeadEnd -> () ] - ; - value get_initial = - fun - [ [Sself :: symbols] -> (True, symbols) - | symbols -> (False, symbols) ] - ; - - - value insert_tokens gram symbols = - let rec insert = - fun - [ Smeta _ sl _ -> List.iter insert sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Stree t -> tinsert t - | Skeyword kwd -> using gram kwd - | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ] - and tinsert = - fun - [ Node {node = s; brother = bro; son = son} -> - do { insert s; tinsert bro; tinsert son } - | LocAct _ _ | DeadEnd -> () ] - in - List.iter insert symbols - ; - - value insert_tree entry gsymbols action tree = - let rec insert symbols tree = - match symbols with - [ [s :: sl] -> insert_in_tree s sl tree - | [] -> - match tree with - [ Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct old_action action_list -> - let () = - if entry.egram.warning_verbose.val then - eprintf " Grammar extension: in [%s] some rule has been masked@." - entry.ename - else () - in LocAct action [old_action :: action_list] - | DeadEnd -> LocAct action [] ] ] - and insert_in_tree s sl tree = - match try_insert s sl tree with - [ Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] - and try_insert s sl tree = - match tree with - [ Node {node = s1; son = son; brother = bro} -> - if Tools.eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - [ Some bro -> bro - | None -> - Node {node = s; son = insert sl DeadEnd; brother = bro} ] - in - let t = Node {node = s1; son = son; brother = bro} in - Some t - else - match try_insert s sl bro with - [ Some bro -> - let t = Node {node = s1; son = son; brother = bro} in - Some t - | None -> None ] - | LocAct _ _ | DeadEnd -> None ] - in - insert gsymbols tree - ; - value insert_level entry e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry symbols action slev.lprefix} ] - ; - - value levels_of_rules entry position rules = - let elev = - match entry.edesc with - [ Dlevels elev -> elev - | Dparser _ -> - do { - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } ] - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - do { - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial symbols; - insert_tokens entry.egram symbols; - insert_level entry e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 - ; - - value extend entry (position, rules) = - let elev = levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - }; - - end; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml deleted file mode 100644 index 48054e4d..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Parser.ml +++ /dev/null @@ -1,431 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Failed = Failed.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Sig.Grammar; - - module StreamOrig = Stream; - - value njunk strm n = - for i = 1 to n do Stream.junk strm done; - - value loc_bp = Tools.get_cur_loc; - value loc_ep = Tools.get_prev_loc; - value drop_prev_loc = Tools.drop_prev_loc; - - value add_loc bp parse_fun strm = - let x = parse_fun strm in - let ep = loc_ep strm in - let loc = - if Loc.start_off bp > Loc.stop_off ep then - (* If nothing has been consumed, create a 0-length location. *) - Loc.join bp - else - Loc.merge bp ep - in - (x, loc); - - value stream_peek_nth strm n = - let rec loop i = fun - [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs - | [] -> None ] - in - loop n (Stream.npeek n strm); - - (* We don't want Stream's functions to be used implictly. *) - module Stream = struct - type t 'a = StreamOrig.t 'a; - exception Failure = StreamOrig.Failure; - exception Error = StreamOrig.Error; - value peek = StreamOrig.peek; - value junk = StreamOrig.junk; - - value dup strm = - (* This version of peek_nth is off-by-one from Stream.peek_nth *) - let peek_nth n = - loop n (Stream.npeek (n + 1) strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n = 0 then Some x else None - | [_ :: l] -> loop (n - 1) l ] - in - Stream.from peek_nth; - end; - - value try_parser ps strm = - let strm' = Stream.dup strm in - let r = - try ps strm' - with - [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) -> - raise Stream.Failure - | exc -> raise exc ] - in do { - njunk strm (StreamOrig.count strm'); - r; - }; - - value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ] - in - match entry.edesc with - [ Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found ] - ; - value strict_parsing = ref False; - value strict_parsing_warning = ref False; - - value rec top_symb entry = - fun - [ Sself | Snext -> Snterm entry - | Snterml e _ -> Snterm e - | Slist1sep s sep -> Slist1sep (top_symb entry s) sep - | _ -> raise Stream.Failure ] - ; - - value top_tree entry = - fun - [ Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct _ _ | DeadEnd -> raise Stream.Failure ] - ; - - value entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> raise Stream.Failure ] - ; - - value continue entry loc a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 loc a; - act = p1 ?? Failed.tree_failed entry a s son :] -> - Action.mk (fun _ -> Action.getf act a) - ; - - (* PR#4603, PR#4330, PR#4551: - Here loc_bp replaced get_loc_ep to fix all these bugs. - If you do change it again look at these bugs. *) - value skip_if_empty bp strm = - if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure) - else - raise Stream.Failure - ; - - value do_recover parser_of_tree entry nlevn alevn loc a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty loc :] -> a - | [: a = - continue entry loc a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] - ; - - - value recover parser_of_tree entry nlevn alevn loc a s son strm = - if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son)) - else - let _ = - if strict_parsing_warning.val then begin - let msg = Failed.tree_failed entry a s son; - Format.eprintf "Warning: trying to recover from syntax error"; - if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); - Format.eprintf "\n%s%a@." msg Loc.print loc; - end else () in - do_recover parser_of_tree entry nlevn alevn loc a s son strm - ; - - value rec parser_of_tree entry nlevn alevn = - fun - [ DeadEnd -> parser [] - | LocAct act _ -> parser [: :] -> act - | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> - parser [: a = entry.estart alevn :] -> Action.getf act a - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = entry.estart alevn :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - parser_of_token_list p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [ [: a = ps; act = p1 bp a :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - let p1 = parser_of_token_list p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = p1 :] -> a - | [: a = p2 :] -> a ] ] ] - and parser_cont p1 entry nlevn alevn s son loc a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a - | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ] - and parser_of_token_list p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [Stoken (tematch, _) :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | [Skeyword kwd :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | _ -> invalid_arg "parser_of_token_list" ] - and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - let pl = List.map (parser_of_symbol entry nlevn) symbl in - Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> Action.mk (List.rev a) - | Slist0sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | [: :] -> Action.mk [] ] - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s)) - | Slist1sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; - a = - parser - [ [: a = ps :] -> a - | [: a = parse_top_symb entry symb :] -> a - | [: :] -> - raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Action.mk (Some a) - | [: :] -> Action.mk None ] - | Stry s -> - let ps = parser_of_symbol entry nlevn s in - try_parser ps - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp pt :] -> - Action.getf act loc - | Snterm e -> parser [: a = e.estart 0 :] -> a - | Snterml e l -> - parser [: a = e.estart (level_number e l) :] -> a - | Sself -> parser [: a = entry.estart 0 :] -> a - | Snext -> parser [: a = entry.estart nlevn :] -> a - | Skeyword kwd -> - parser - [: `(tok, _) when Token.match_keyword kwd tok :] -> - Action.mk tok - | Stoken (f, _) -> - parser - [: `(tok,_) when f tok :] -> Action.mk tok ] - and parse_top_symb entry symb strm = - parser_of_symbol entry 0 (top_symb entry symb) strm; - - value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun _ -> parser [] - | [lev :: levs] -> - let p1 = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - match levs with - [ [] -> - fun levn strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp p2; strm :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let bp = loc_bp strm in - match strm with parser - [ [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | [: act = p1 levn :] -> act ] ] ] ] - ; - - value start_parser_of_entry entry = - debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels [] -> Tools.empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun _ -> p ] - ; - value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun _ _ _ -> parser [] - | [lev :: levs] -> - let p1 = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm - else - match strm with parser - [ [: act = p1 levn bp a :] -> act - | [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf2 act a loc in - entry.econtinue levn loc a strm ] ] ] - ; - - value continue_parser_of_entry entry = - debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - fun levn bp a -> - parser - [ [: a = p levn bp a :] -> a - | [: :] -> a ] - | Dparser _ -> fun _ _ _ -> parser [] ] - ; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli deleted file mode 100644 index 74e0fe07..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Parser.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - value add_loc : - Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t); - value level_number : internal_entry -> string -> int; - value strict_parsing : ref bool; - value strict_parsing_warning : ref bool; - value top_symb : - internal_entry -> symbol -> symbol; - value top_tree : - internal_entry -> tree -> tree; - value entry_of_symb : - internal_entry -> symbol -> internal_entry; - value continue : - internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun; - value do_recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value parser_of_tree : - internal_entry -> int -> int -> tree -> efun; - value parser_cont : - efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun; - value parser_of_token_list : - (Loc.t -> Action.t -> efun) -> list symbol -> efun; - value parser_of_symbol : - internal_entry -> int -> symbol -> efun; - value parse_top_symb : - internal_entry -> symbol -> efun; - value start_parser_of_levels : - internal_entry -> int -> list level -> int -> efun; - value start_parser_of_entry : - internal_entry -> int -> efun; - value continue_parser_of_levels : - internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun; - value continue_parser_of_entry : - internal_entry -> int -> Loc.t -> Action.t -> efun; -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Print.ml b/camlp4/Camlp4/Struct/Grammar/Print.ml deleted file mode 100644 index 06e09c21..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Print.ml +++ /dev/null @@ -1,270 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ]; - - value rec print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; - -module MakeDump (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - type brothers = [ Bro of symbol and list brothers ]; - - value rec print_tree ppf tree = - let rec get_brothers acc = - fun - [ DeadEnd -> List.rev acc - | LocAct _ _ -> List.rev acc - | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ] - and print_brothers ppf brothers = - if brothers = [] then fprintf ppf "@ []" - else - List.iter (fun [ Bro n xs -> do { - fprintf ppf "@ @[- %a" print_symbol n; - match xs with - [ [] -> () - | [_] -> try print_children ppf (get_children [] xs) - with [ Exit -> fprintf ppf ":%a" print_brothers xs ] - | _ -> fprintf ppf ":%a" print_brothers xs ]; - fprintf ppf "@]"; - }]) brothers - and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) - and get_children acc = - fun - [ [] -> List.rev acc - | [Bro n x] -> get_children [n::acc] x - | _ -> raise Exit ] - in print_brothers ppf (get_brothers [] tree) - and print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_tree ppf t - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - fprintf ppf "@[suffix:@ "; - print_tree ppf lev.lsuffix; - fprintf ppf "@]@ @[prefix:@ "; - print_tree ppf lev.lprefix; - fprintf ppf "@]"; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Print.mli b/camlp4/Camlp4/Struct/Grammar/Print.mli deleted file mode 100644 index b1059a6d..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Print.mli +++ /dev/null @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - value flatten_tree : Structure.tree -> list (list Structure.symbol); - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; - -module MakeDump (Structure : Structure.S) : sig - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Search.ml b/camlp4/Camlp4/Struct/Grammar/Search.ml deleted file mode 100644 index 226a0d44..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Search.ml +++ /dev/null @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; -value tree_in_entry prev_symb tree = - fun - [ Dlevels levels -> - let rec search_levels = - fun - [ [] -> tree - | [level :: levels] -> - match search_level level with - [ Some tree -> tree - | None -> search_levels levels ] ] - and search_level level = - match search_tree level.lsuffix with - [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix ] - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - [ Node n -> - match search_symbol n.node with - [ Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - [ Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother ] ] - | LocAct _ _ | DeadEnd -> None ] - and search_symbol symb = - match symb with - [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist0 symb) - | None -> None ] - | Slist0sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist0sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist0sep symb sep) - | None -> None ] ] - | Slist1 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist1 symb) - | None -> None ] - | Slist1sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist1sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist1sep symb sep) - | None -> None ] ] - | Sopt symb -> - match search_symbol symb with - [ Some symb -> Some (Sopt symb) - | None -> None ] - | Stry symb -> - match search_symbol symb with - [ Some symb -> Some (Stry symb) - | None -> None ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Static.ml b/camlp4/Camlp4/Struct/Grammar/Static.ml deleted file mode 100644 index 02aec0b1..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Static.ml +++ /dev/null @@ -1,84 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring -*) - -value uncurry f (x,y) = f x y; -value flip f x y = f y x; - -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Static with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value gram = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - module Entry = struct - module E = Entry.Make Structure; - type t 'a = E.t 'a; - value mk = E.mk gram; - value of_parser name strm = E.of_parser gram name strm; - value setup_parser = E.setup_parser; - value name = E.name; - value print = E.print; - value clear = E.clear; - value dump = E.dump; - value obj x = x; - end; - - value get_filter () = gram.gfilter; - - value lex loc cs = gram.glexer loc cs; - - value lex_string loc str = lex loc (Stream.of_string str); - - value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs); - - value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; - -end; diff --git a/camlp4/Camlp4/Struct/Grammar/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml deleted file mode 100644 index e2a79b18..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Structure.ml +++ /dev/null @@ -1,294 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -open Sig.Grammar; - -module type S = sig - module Loc : Sig.Loc; - module Token : Sig.Token with module Loc = Loc; - module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; - module Action : Sig.Grammar.Action; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - (* Accessors *) - value get_filter : gram -> Token.Filter.t; - - (* Useful functions *) - value using : gram -> string -> unit; - value removing : gram -> string -> unit; -end; - -module Make (Lexer : Sig.Lexer) = struct - module Loc = Lexer.Loc; - module Token = Lexer.Token; - module Action : Sig.Grammar.Action = struct - type t = Obj.t ; - value mk = Obj.repr; - value get = Obj.obj ; - value getf = Obj.obj ; - value getf2 = Obj.obj ; - end; - module Lexer = Lexer; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - value get_filter g = g.gfilter; - value token_location r = r.cur_loc; - - type not_filtered 'a = 'a; - value using { gkeywords = table; gfilter = filter } kwd = - let r = try Hashtbl.find table kwd with - [ Not_found -> - let r = ref 0 in do { Hashtbl.add table kwd r; r } ] - in do { Token.Filter.keyword_added filter kwd (r.val = 0); - incr r }; - - value removing { gkeywords = table; gfilter = filter } kwd = - let r = Hashtbl.find table kwd in - let () = decr r in - if r.val = 0 then do { - Token.Filter.keyword_removed filter kwd; - Hashtbl.remove table kwd - } else (); -end; - -(* -value iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e treated.val then () - else do { - treated.val := [e :: treated.val]; - f e; - match e.edesc with - [ Dlevels ll -> List.iter do_level ll - | Dparser _ -> () ] - } - and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } - and do_tree = - fun - [ Node n -> do_node n - | LocAct _ _ | DeadEnd -> () ] - and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } - and do_symbol = - fun - [ Smeta _ sl _ -> List.iter do_symbol sl - | Snterm e | Snterml e _ -> do_entry e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> () ] - in - do_entry e -; - -value fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e treated.val then accu - else do { - treated.val := [e :: treated.val]; - let accu = f e accu in - match e.edesc with - [ Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu ] - } - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in - do_tree accu lev.lprefix - and do_tree accu = - fun - [ Node n -> do_node accu n - | LocAct _ _ | DeadEnd -> accu ] - and do_node accu n = - let accu = do_symbol accu n.node in - let accu = do_tree accu n.son in - do_tree accu n.brother - and do_symbol accu = - fun - [ Smeta _ sl _ -> List.fold_left do_symbol accu sl - | Snterm e | Snterml e _ -> do_entry accu e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> - let accu = do_symbol accu s1 in - do_symbol accu s2 - | Stree t -> do_tree accu t - | Sself | Snext | Stoken _ | Stoken_fun _ -> accu ] - in - do_entry init e -; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value tokens g con = - let list = ref [] in - do { - Hashtbl.iter - (fun (p_con, p_prm) c -> - if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) - g.gtokens; - list.val - } -; -*) diff --git a/camlp4/Camlp4/Struct/Grammar/Tools.ml b/camlp4/Camlp4/Struct/Grammar/Tools.ml deleted file mode 100644 index df4b03fe..00000000 --- a/camlp4/Camlp4/Struct/Grammar/Tools.ml +++ /dev/null @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -(* PR#5090: don't do lookahead on get_prev_loc. *) -value get_prev_loc_only = ref False; - -module Make (Structure : Structure.S) = struct - open Structure; - - value empty_entry ename _ = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); - - value rec stream_map f = parser - [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] - | [: :] -> [: :] ]; - - value keep_prev_loc strm = - match Stream.peek strm with - [ None -> [: :] - | Some (tok0,init_loc) -> - let rec go prev_loc strm1 = - if get_prev_loc_only.val then - [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True}); - go prev_loc strm1 :] - else - match strm1 with parser - [ [: `(tok,cur_loc); strm :] -> - [: `(tok, {prev_loc; cur_loc; prev_loc_only = False}); - go cur_loc strm :] - | [: :] -> [: :] ] - in go init_loc strm ]; - - value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; - - value get_cur_loc strm = - match Stream.peek strm with - [ Some (_,r) -> r.cur_loc - | None -> Loc.ghost ]; - - value get_prev_loc strm = - begin - get_prev_loc_only.val := True; - let result = match Stream.peek strm with - [ Some (_, {prev_loc; prev_loc_only = True}) -> - begin Stream.junk strm; prev_loc end - | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc - | None -> Loc.ghost ]; - get_prev_loc_only.val := False; - result - end; - - value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ]; - - value warning_verbose = ref True; - - value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} -> - get_token_list entry [last_tok :: tokl] tok son - | _ -> - if tokl = [] then None - else Some (List.rev [last_tok :: tokl], last_tok, tree) ]; - - value is_antiquot s = - let len = String.length s in - len > 1 && s.[0] = '$'; - - value eq_Stoken_ids s1 s2 = - not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2; - - value logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - and eq_trees t1 t2 = - match (t1, t2) with - [ (Node n1, Node n2) -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True - | _ -> False ] - in - eq_symbols; - - value rec eq_symbol s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Stree _, Stree _) -> False - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - ; -end; diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll deleted file mode 100644 index 6d5099a8..00000000 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ /dev/null @@ -1,495 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(* The lexer definition *) - - -{ - -(** A lexical analyzer. *) - -(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) -(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) - -(* type context = -{ loc : Loc.t ; - in_comment : bool ; - |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). +| - quotations : bool }; - -value default_context : context; - -value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - -value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) -(* FIXME Beware the context argument must be given like that: - * mk' { (default_context) with ... = ... } strm - *) - -module TokenEval = Token.Eval -module Make (Token : Sig.Camlp4Token) -= struct - module Loc = Token.Loc - module Token = Token - - open Lexing - open Sig - - (* Error report *) - module Error = struct - - type t = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment - | Unterminated_string - | Unterminated_quotation - | Unterminated_antiquot - | Unterminated_string_in_comment - | Comment_start - | Comment_not_end - | Literal_overflow of string - - exception E of t - - open Format - - let print ppf = - function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> - fprintf ppf "This comment contains an unterminated string literal" - | Unterminated_quotation -> - fprintf ppf "Quotation not terminated" - | Unterminated_antiquot -> - fprintf ppf "Antiquotation not terminated" - | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty - | Comment_start -> - fprintf ppf "this is the start of a comment" - | Comment_not_end -> - fprintf ppf "this is not the end of a comment" - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - end;; - - let module M = ErrorHandler.Register(Error) in () - - open Error - - (* To store some context information: - * loc : position of the beginning of a string, quotation and comment - * in_comment: are we in a comment? - * quotations: shall we lex quotation? - * If quotations is false it's a SYMBOL token. - * antiquots : shall we lex antiquotations. - *) - - type context = - { loc : Loc.t ; - in_comment : bool ; - quotations : bool ; - antiquots : bool ; - lexbuf : lexbuf ; - buffer : Buffer.t } - - let default_context lb = - { loc = Loc.ghost ; - in_comment = false ; - quotations = true ; - antiquots = false ; - lexbuf = lb ; - buffer = Buffer.create 256 } - - (* To buffer string literals, quotations and antiquotations *) - - let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) - let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) - let buff_contents c = - let contents = Buffer.contents c.buffer in - Buffer.reset c.buffer; contents - - let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) - let quotations c = c.quotations - let antiquots c = c.antiquots - let is_in_comment c = c.in_comment - let in_comment c = { (c) with in_comment = true } - let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc - let move_start_p shift c = - let p = c.lexbuf.lex_start_p in - c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } - - let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } - let with_curr_loc f c = f (update_loc c) c.lexbuf - let parse_nested f c = - with_curr_loc f c; - set_start_p c; - buff_contents c - let shift n c = { (c) with loc = Loc.move `both n c.loc } - let store_parse f c = store c ; f c c.lexbuf - let parse f c = f c c.lexbuf - let mk_quotation quotation c name loc shift = - let s = parse_nested quotation (update_loc c) in - let contents = String.sub s 0 (String.length s - 2) in - QUOTATION { q_name = name ; - q_loc = loc ; - q_shift = shift ; - q_contents = contents } - - - (* Update the current location with file name and line number. *) - - let update_loc c file line absolute chars = - let lexbuf = c.lexbuf in - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - - (* To convert integer literals, copied from "../parsing/lexer.mll" *) - - let cvt_int_literal s = - - int_of_string ("-" ^ s) - let cvt_int32_literal s = - Int32.neg (Int32.of_string ("-" ^ s)) - let cvt_int64_literal s = - Int64.neg (Int64.of_string ("-" ^ s)) - let cvt_nativeint_literal s = - Nativeint.neg (Nativeint.of_string ("-" ^ s)) - - - let err error loc = - raise(Loc.Exc_located(loc, Error.E error)) - - let warn error loc = - Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error - - } - - let newline = ('\010' | '\013' | "\013\010") - let blank = [' ' '\009' '\012'] - let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] - let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] - let identchar = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] - let ident = (lowercase|uppercase) identchar* - let locname = ident - let not_star_symbolchar = - ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] - let symbolchar = '*' | not_star_symbolchar - let quotchar = - ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] - let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] - let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* - let hex_literal = - '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* - let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* - let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* - let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal - let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? - - (* Delimitors are extended (from 3.09) in a conservative way *) - - (* These chars that can't start an expression or a pattern: *) - let safe_delimchars = ['%' '&' '/' '@' '^'] - - (* These symbols are unsafe since "[<", "[|", etc. exsist. *) - let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] - - let left_delims = ['(' '[' '{'] - let right_delims = [')' ']' '}'] - - let left_delimitor = - (* At least a safe_delimchars *) - left_delims delimchars* safe_delimchars (delimchars|left_delims)* - - (* A '(' or a new super '(' without "(<" *) - | '(' (['|' ':'] delimchars*)? - (* Old brackets, no new brackets starting with "[|" or "[:" *) - | '[' ['|' ':']? - (* Old "[<","{<" and new ones *) - | ['[' '{'] delimchars* '<' - (* Old brace and new ones *) - | '{' (['|' ':'] delimchars*)? - - let right_delimitor = - (* At least a safe_delimchars *) - (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims - (* A ')' or a new super ')' without ">)" *) - | (delimchars* ['|' ':'])? ')' - (* Old brackets, no new brackets ending with "|]" or ":]" *) - | ['|' ':']? ']' - (* Old ">]",">}" and new ones *) - | '>' delimchars* [']' '}'] - (* Old brace and new ones *) - | (delimchars* ['|' ':'])? '}' - - - rule token c = parse - | newline { update_loc c None 1 false 0; NEWLINE } - | blank + as x { BLANKS x } - | "~" (lowercase identchar * as x) ':' { LABEL x } - | "?" (lowercase identchar * as x) ':' { OPTLABEL x } - | lowercase identchar * as x { LIDENT x } - | uppercase identchar * as x { UIDENT x } - | int_literal as i - { try INT(cvt_int_literal i, i) - with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } - | float_literal as f - { try FLOAT(float_of_string f, f) - with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "l" - { try INT32(cvt_int32_literal i, i) - with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "L" - { try INT64(cvt_int64_literal i, i) - with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "n" - { try NATIVEINT(cvt_nativeint_literal i, i) - with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } - | '"' - { with_curr_loc string c; - let s = buff_contents c in STRING (TokenEval.string s, s) } - | "'" (newline as x) "'" - { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } - | "'" ( [^ '\\' '\010' '\013'] - | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] - |['0'-'9'] ['0'-'9'] ['0'-'9'] - |'x' hexa_char hexa_char) - as x) "'" { CHAR (TokenEval.char x, x) } - | "'\\" (_ as c) - { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } - | "(*" - { store c; COMMENT(parse_nested comment (in_comment c)) } - | "(*)" - { warn Comment_start (Loc.of_lexbuf lexbuf) ; - parse comment (in_comment c); COMMENT (buff_contents c) } - | "*)" - { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; - move_start_p (-1) c; SYMBOL "*" } - | "<<" (quotchar* as beginning) - { if quotations c - then (move_start_p (-String.length beginning); - mk_quotation quotation c "" "" 2) - else parse (symbolchar_star ("<<" ^ beginning)) c } - | "<<>>" - { if quotations c - then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } - else parse (symbolchar_star "<<>>") c } - | "<@" - { if quotations c then with_curr_loc maybe_quotation_at c - else parse (symbolchar_star "<@") c } - | "<:" - { if quotations c then with_curr_loc maybe_quotation_colon c - else parse (symbolchar_star "<:") c } - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { let inum = int_of_string num - in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } - | '(' (not_star_symbolchar as op) ')' - { ESCAPED_IDENT (String.make 1 op) } - | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar+ as op) blank+ ')' - { ESCAPED_IDENT op } - | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" - | ":=" | ":>" | ";" | ";;" | "_" - | left_delimitor | right_delimitor ) as x { SYMBOL x } - | '$' { if antiquots c - then with_curr_loc dollar (shift 1 c) - else parse (symbolchar_star "$") c } - | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * - as x { SYMBOL x } - | eof - { let pos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; - pos_cnum = pos.pos_cnum + 1 }; EOI } - | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } - - and comment c = parse - "(*" - { store c; with_curr_loc comment c; parse comment c } - | "*)" { store c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; - if quotations c then with_curr_loc quotation c; parse comment c } - | ident { store_parse comment c } - | "\"" - { store c; - begin try with_curr_loc string c - with Loc.Exc_located(_, Error.E Unterminated_string) -> - err Unterminated_string_in_comment (loc c) - end; - Buffer.add_char c.buffer '"'; - parse comment c } - | "''" { store_parse comment c } - | "'''" { store_parse comment c } - | "'" newline "'" - { update_loc c None 1 false 1; store_parse comment c } - | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } - | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } - | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } - | eof - { err Unterminated_comment (loc c) } - | newline - { update_loc c None 1 false 0; store_parse comment c } - | _ { store_parse comment c } - - and string c = parse - '"' { set_start_p c } - | '\\' newline ([' ' '\t'] * as space) - { update_loc c None 1 false (String.length space); - store_parse string c } - | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } - | '\\' 'x' hexa_char hexa_char { store_parse string c } - | '\\' (_ as x) - { if is_in_comment c - then store_parse string c - else begin - warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); - store_parse string c - end } - | newline - { update_loc c None 1 false 0; store_parse string c } - | eof { err Unterminated_string (loc c) } - | _ { store_parse string c } - - and symbolchar_star beginning c = parse - | symbolchar* as tok { move_start_p (-String.length beginning) c ; - SYMBOL(beginning ^ tok) } - - and maybe_quotation_at c = parse - | (ident as loc) '<' - { mk_quotation quotation c "" loc (1 + String.length loc) } - | symbolchar* as tok { SYMBOL("<@" ^ tok) } - - and maybe_quotation_colon c = parse - | (ident as name) '<' - { mk_quotation quotation c name "" (1 + String.length name) } - | (ident as name) '@' (locname as loc) '<' - { mk_quotation quotation c name loc - (2 + String.length loc + String.length name) } - | symbolchar* as tok { SYMBOL("<:" ^ tok) } - - and quotation c = parse - | '<' (':' ident)? ('@' locname)? '<' { store c ; - with_curr_loc quotation c ; - parse quotation c } - | ">>" { store c } - | eof { err Unterminated_quotation (loc c) } - | newline { update_loc c None 1 false 0 ; - store_parse quotation c } - | _ { store_parse quotation c } - - and dollar c = parse - | '$' { set_start_p c; ANTIQUOT("", "") } - | ('`'? (identchar*|['.' '!']+) as name) ':' - { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } - | _ { store_parse (antiquot "") c } - - and antiquot name c = parse - | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } - | eof { err Unterminated_antiquot (loc c) } - | newline - { update_loc c None 1 false 0; store_parse (antiquot name) c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; with_curr_loc quotation c; parse (antiquot name) c } - | _ { store_parse (antiquot name) c } - - { - - let lexing_store s buff max = - let rec self n s = - if n >= max then n - else - match Stream.peek s with - | Some x -> - Stream.junk s; - buff.[n] <- x; - succ n - | _ -> n - in - self 0 s - - let from_context c = - let next _ = - let tok = with_curr_loc token c in - let loc = Loc.of_lexbuf c.lexbuf in - Some ((tok, loc)) - in Stream.from next - - let from_lexbuf ?(quotations = true) lb = - let c = { (default_context lb) with - loc = Loc.of_lexbuf lb; - antiquots = !Camlp4_config.antiquotations; - quotations = quotations } - in from_context c - - let setup_loc lb loc = - let start_pos = Loc.start_pos loc in - lb.lex_abs_pos <- start_pos.pos_cnum; - lb.lex_curr_p <- start_pos - - let from_string ?quotations loc str = - let lb = Lexing.from_string str in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let from_stream ?quotations loc strm = - let lb = Lexing.from_function (lexing_store strm) in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let mk () loc strm = - from_stream ~quotations:!Camlp4_config.quotations loc strm -end -} diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml deleted file mode 100644 index 2fd2c910..00000000 --- a/camlp4/Camlp4/Struct/Loc.ml +++ /dev/null @@ -1,307 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -(* FIXME - Study these 2 others implementations which change the ghost - handling: - - type pos = ... the same ... - - 1/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = - [ Nowhere - | Ghost of loc (* the closest non ghost loc *) - | Concrete of loc ]; - - 2/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = option loc; - - 3/ - - type t = { - file_name : option string; - start : pos; - stop : pos - }; - -*) - -type pos = { - line : int; - bol : int; - off : int -}; - -type t = { - file_name : string; - start : pos; - stop : pos; - ghost : bool -}; - -(* Debug section *) -value dump_sel f x = - let s = - match x with - [ `start -> "`start" - | `stop -> "`stop" - | `both -> "`both" - | _ -> "" ] - in pp_print_string f s; -value dump_pos f x = - fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" - x.line x.bol x.off; -value dump_long f x = - fprintf f - "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" - x.file_name dump_pos x.start (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) dump_pos x.stop - (x.stop.off - x.stop.bol) x.ghost; -value dump f x = - fprintf f "[%S: %d:%d-%d %d:%d%t]" - x.file_name x.start.line (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) - (fun o -> if x.ghost then fprintf o " (ghost)" else ()); - -value start_pos = { line = 1 ; bol = 0 ; off = 0 }; - -value ghost = - { file_name = "ghost-location"; - start = start_pos; - stop = start_pos; - ghost = True }; - -value mk file_name = - debug loc "mk %s@\n" file_name in - { file_name = file_name; - start = start_pos; - stop = start_pos; - ghost = False }; - -value of_tuple (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost) = - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost }; - -value to_tuple - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost } = - (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost); - -value pos_of_lexing_position p = - let pos = - { line = p.Lexing.pos_lnum ; - bol = p.Lexing.pos_bol ; - off = p.Lexing.pos_cnum } in - debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in - pos; - -value pos_to_lexing_position p file_name = - (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) - { Lexing. - pos_fname = file_name; - pos_lnum = p.line ; - pos_bol = p.bol ; - pos_cnum = p.off }; - -value better_file_name a b = - match (a, b) with - [ ("", "") -> a - | ("", x) -> x - | (x, "") -> x - | ("-", x) -> x - | (x, "-") -> x - | (x, _) -> x ]; - -value of_lexbuf lb = - let start = Lexing.lexeme_start_p lb - and stop = Lexing.lexeme_end_p lb in - let loc = - { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; - start = pos_of_lexing_position start; - stop = pos_of_lexing_position stop; - ghost = False } in - debug loc "of_lexbuf: %a@\n" dump loc in - loc; - -value of_lexing_position pos = - let loc = - { file_name = pos.Lexing.pos_fname; - start = pos_of_lexing_position pos; - stop = pos_of_lexing_position pos; - ghost = False } in - debug loc "of_lexing_position: %a@\n" dump loc in - loc; - -value to_ocaml_location x = - debug loc "to_ocaml_location: %a@\n" dump x in - { Camlp4_import.Location. - loc_start = pos_to_lexing_position x.start x.file_name; - loc_end = pos_to_lexing_position x.stop x.file_name; - loc_ghost = x.ghost }; - -value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = - let res = - { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; - start = pos_of_lexing_position a; - stop = pos_of_lexing_position b; - ghost = g } in - debug loc "of_ocaml_location: %a@\n" dump res in - res; - -value start_pos x = pos_to_lexing_position x.start x.file_name; -value stop_pos x = pos_to_lexing_position x.stop x.file_name; - -value merge a b = - if a == b then - debug loc "trivial merge@\n" in - a - else - let r = - match (a.ghost, b.ghost) with - [ (False, False) -> - (* FIXME if a.file_name <> b.file_name then - raise (Invalid_argument - (sprintf "Loc.merge: Filenames must be equal: %s <> %s" - a.file_name b.file_name)) *) - (* else *) - { (a) with stop = b.stop } - | (True, True) -> { (a) with stop = b.stop } - | (True, _) -> { (a) with stop = b.stop } - | (_, True) -> { (b) with start = a.start } ] - in debug loc "@[merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; - -value join x = { (x) with stop = x.start }; - -value map f start_stop_both x = - match start_stop_both with - [ `start -> { (x) with start = f x.start } - | `stop -> { (x) with stop = f x.stop } - | `both -> { (x) with start = f x.start; stop = f x.stop } ]; - -value move_pos chars x = { (x) with off = x.off + chars }; - -value move s chars x = - debug loc "move %a %d %a@\n" dump_sel s chars dump x in - map (move_pos chars) s x; - -value move_line lines x = - debug loc "move_line %d %a@\n" lines dump x in - let move_line_pos x = - { (x) with line = x.line + lines ; bol = x.off } - in map move_line_pos `both x; - -value shift width x = - { (x) with start = x.stop ; stop = move_pos width x.stop }; - -value file_name x = x.file_name; -value start_line x = x.start.line; -value stop_line x = x.stop.line; -value start_bol x = x.start.bol; -value stop_bol x = x.stop.bol; -value start_off x = x.start.off; -value stop_off x = x.stop.off; -value is_ghost x = x.ghost; - -value set_file_name s x = - debug loc "set_file_name: %a@\n" dump x in - { (x) with file_name = s }; - -value ghostify x = - debug loc "ghostify: %a@\n" dump x in - { (x) with ghost = True }; - -value make_absolute x = - debug loc "make_absolute: %a@\n" dump x in - let pwd = Sys.getcwd () in - if Filename.is_relative x.file_name then - { (x) with file_name = Filename.concat pwd x.file_name } - else x; - -value strictly_before x y = - let b = x.stop.off < y.start.off && x.file_name = y.file_name in - debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in - b; - -value to_string x = do { - let (a, b) = (x.start, x.stop) in - let res = sprintf "File \"%s\", line %d, characters %d-%d" - x.file_name a.line (a.off - a.bol) (b.off - a.bol) in - if x.start.line <> x.stop.line then - sprintf "%s (end at line %d, character %d)" - res x.stop.line (b.off - b.bol) - else res -}; - -value print out x = pp_print_string out (to_string x); - -value check x msg = - if ((start_line x) > (stop_line x) || - (start_bol x) > (stop_bol x) || - (start_off x) > (stop_off x) || - (start_line x) < 0 || (stop_line x) < 0 || - (start_bol x) < 0 || (stop_bol x) < 0 || - (start_off x) < 0 || (stop_off x) < 0) - (* Here, we don't check - (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) - since the lexer is called on antiquotations, with off=0, but line and bolpos - have "correct" values *) - then do { - eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; - False - } - else True; - -exception Exc_located of t and exn; - -ErrorHandler.register - (fun ppf -> - fun [ Exc_located loc exn -> - fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn - | exn -> raise exn ]); - -value name = ref "_loc"; - -value raise loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; diff --git a/camlp4/Camlp4/Struct/Loc.mli b/camlp4/Camlp4/Struct/Loc.mli deleted file mode 100644 index c6c523fc..00000000 --- a/camlp4/Camlp4/Struct/Loc.mli +++ /dev/null @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Loc; diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml deleted file mode 100644 index c9d6169a..00000000 --- a/camlp4/Camlp4/Struct/Quotation.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) -: Sig.Quotation with module Ast = Ast -= struct - module Ast = Ast; - module DynAst = DynAst.Make Ast; - module Loc = Ast.Loc; - open Format; - open Sig; - - type expand_fun 'a = Loc.t -> option string -> string -> 'a; - - module Exp_key = DynAst.Pack(struct - type t 'a = unit; - end); - - module Exp_fun = DynAst.Pack(struct - type t 'a = expand_fun 'a; - end); - - value expanders_table = - (ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack))); - - value default = ref ""; - value translate = ref (fun x -> x); - - value expander_name name = - match translate.val name with - [ "" -> default.val - | name -> name ]; - - value find name tag = - let key = (expander_name name, Exp_key.pack tag ()) in - Exp_fun.unpack tag (List.assoc key expanders_table.val); - - value add name tag f = - let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in - expanders_table.val := [elt :: expanders_table.val]; - - value dump_file = ref None; - - module Error = struct - type error = - [ Finding - | Expanding - | ParsingResult of Loc.t and string - | Locating ]; - type t = (string * string * error * exn); - exception E of t; - - value print ppf (name, position, ctx, exn) = - let name = if name = "" then default.val else name in - let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in - let () = - match ctx with - [ Finding -> begin - pp "finding quotation"; - if expanders_table.val = [] then - fprintf ppf "@ There is no quotation expander available." - else - begin - fprintf ppf "@ @[Available quotation expanders are:@\n"; - List.iter begin fun ((s,t),_) -> - fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " - s Exp_key.print_tag t - end expanders_table.val; - fprintf ppf "@]" - end - end - | Expanding -> pp "expanding quotation" - | Locating -> pp "parsing" - | ParsingResult loc str -> - let () = pp "parsing result of quotation" in - match dump_file.val with - [ Some dump_file -> - let () = fprintf ppf " dumping result...\n" in - try - let oc = open_out_bin dump_file in - begin - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc); - end - with _ -> - fprintf ppf - "Error while dumping result in file %S; dump aborted" - dump_file - | None -> - fprintf ppf - "\n(consider setting variable Quotation.dump_file, or using the -QD option)" - ] - ] - in fprintf ppf "@\n%a@]@." ErrorHandler.print exn; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - open Error; - - value expand_quotation loc expander pos_tag quot = - debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in - let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in - try expander loc loc_name_opt quot.q_contents with - [ Loc.Exc_located _ (Error.E _) as exc -> - raise exc - | Loc.Exc_located iloc exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located iloc exc1) - | exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located loc exc1) ]; - - value parse_quotation_result parse loc quot pos_tag str = - try parse loc str with - [ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (n, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) - | Loc.Exc_located iloc (Error.E _ as exc) -> - raise (Loc.Exc_located iloc exc) - | Loc.Exc_located iloc exc -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) ]; - - value expand loc quotation tag = - let pos_tag = DynAst.string_of_tag tag in - let name = quotation.q_name in - debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in - let expander = - try find name tag - with - [ Loc.Exc_located _ (Error.E _) as exc -> raise exc - | Loc.Exc_located qloc exc -> - raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc))) - | exc -> - raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ] - in - let loc = Loc.join (Loc.move `start quotation.q_shift loc) in - expand_quotation loc expander pos_tag quotation; - -end; diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml deleted file mode 100644 index 701e990d..00000000 --- a/camlp4/Camlp4/Struct/Token.ml +++ /dev/null @@ -1,244 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Token with module Loc = Loc -= struct - module Loc = Loc; - open Sig; - type t = camlp4_token; - type token = t; - - value to_string = - fun - [ KEYWORD s -> sprintf "KEYWORD %S" s - | SYMBOL s -> sprintf "SYMBOL %S" s - | LIDENT s -> sprintf "LIDENT %S" s - | UIDENT s -> sprintf "UIDENT %S" s - | INT _ s -> sprintf "INT %s" s - | INT32 _ s -> sprintf "INT32 %sd" s - | INT64 _ s -> sprintf "INT64 %sd" s - | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s - | FLOAT _ s -> sprintf "FLOAT %s" s - | CHAR _ s -> sprintf "CHAR '%s'" s - | STRING _ s -> sprintf "STRING \"%s\"" s - (* here it's not %S since the string is already escaped *) - | LABEL s -> sprintf "LABEL %S" s - | OPTLABEL s -> sprintf "OPTLABEL %S" s - | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s - | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" - x.q_name x.q_loc x.q_shift x.q_contents - | COMMENT s -> sprintf "COMMENT %S" s - | BLANKS s -> sprintf "BLANKS %S" s - | NEWLINE -> sprintf "NEWLINE" - | EOI -> sprintf "EOI" - | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s - | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i - | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ]; - - value print ppf x = pp_print_string ppf (to_string x); - - value match_keyword kwd = - fun - [ KEYWORD kwd' when kwd = kwd' -> True - | _ -> False ]; - - value extract_string = - fun - [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s | - INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s | - LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s - | tok -> - invalid_arg ("Cannot extract a string from this token: "^ - to_string tok) ]; - - module Error = struct - type t = - [ Illegal_token of string - | Keyword_as_label of string - | Illegal_token_pattern of string and string - | Illegal_constructor of string ]; - - exception E of t; - - value print ppf = - fun - [ Illegal_token s -> - fprintf ppf "Illegal token (%s)" s - | Keyword_as_label kwd -> - fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Illegal_token_pattern p_con p_prm -> - fprintf ppf "Illegal token pattern: %s %S" p_con p_prm - | Illegal_constructor con -> - fprintf ppf "Illegal constructor %S" con ]; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - - module Filter = struct - type token_filter = stream_filter t Loc.t; - - type t = - { is_kwd : string -> bool; - filter : mutable token_filter }; - - value err error loc = - raise (Loc.Exc_located loc (Error.E error)); - - value keyword_conversion tok is_kwd = - match tok with - [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s - | ESCAPED_IDENT s -> LIDENT s - | _ -> tok ]; - - value check_keyword_as_label tok loc is_kwd = - let s = - match tok with - [ LABEL s -> s - | OPTLABEL s -> s - | _ -> "" ] - in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else (); - - value check_unknown_keywords tok loc = - match tok with - [ SYMBOL s -> err (Error.Illegal_token s) loc - | _ -> () ]; - - value error_no_respect_rules p_con p_prm = - raise (Error.E (Error.Illegal_token_pattern p_con p_prm)); - - value check_keyword _ = True; - (* FIXME let lb = Lexing.from_string s in - let next () = token default_context lb in - try - match next () with - [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI) - | _ -> False ] - with [ Stream.Error _ -> False ]; *) - - value error_on_unknown_keywords = ref False; - - value rec ignore_layout = - parser - [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] -> - ignore_layout s - | [: ` x; s :] -> [: ` x; ignore_layout s :] - | [: :] -> [: :] ]; - - value mk is_kwd = - { is_kwd = is_kwd; - filter = ignore_layout }; - - value filter x = - let f tok loc = do { - let tok = keyword_conversion tok x.is_kwd; - check_keyword_as_label tok loc x.is_kwd; - if error_on_unknown_keywords.val - then check_unknown_keywords tok loc else (); - debug token "@[Lexer before filter:@ %a@ at@ %a@]@." - print tok Loc.dump loc in - (tok, loc) - } in - let rec filter = - parser - [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :] - | [: :] -> [: :] ] - in - let rec tracer = (* FIXME add a debug block construct *) - parser - [ [: `((_tok, _loc) as x); xs :] -> - debug token "@[Lexer after filter:@ %a@ at@ %a@]@." - print _tok Loc.dump _loc in - [: ` x; tracer xs :] - | [: :] -> [: :] ] - in fun strm -> tracer (x.filter (filter strm)); - - value define_filter x f = x.filter := f x.filter; - - value keyword_added _ _ _ = (); - value keyword_removed _ _ = (); - end; - -end; - -(* Char and string tokens to real chars and string *) -module Eval = struct - - value valch x = Char.code x - Char.code '0'; - value valch_hex x = - let d = Char.code x in - if d >= 97 then d - 87 - else if d >= 65 then d - 55 - else d - 48; - - value rec skip_indent = parser - [ [: `' ' | '\t'; s :] -> skip_indent s - | [: :] -> () ]; - - value skip_opt_linefeed = parser - [ [: `'\010' :] -> () - | [: :] -> () ]; - - value chr c = - if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c; - - value rec backslash = parser - [ [: `'\010' :] -> '\010' - | [: `'\013' :] -> '\013' - | [: `'n' :] -> '\n' - | [: `'r' :] -> '\r' - | [: `'t' :] -> '\t' - | [: `'b' :] -> '\b' - | [: `'\\' :] -> '\\' - | [: `'"' :] -> '"' - | [: `'\'' :] -> '\'' - | [: `' ' :] -> ' ' - | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> - chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) - | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ; - `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] -> - chr (16 * (valch_hex c1) + (valch_hex c2)) ]; - - value rec backslash_in_string strict store = parser - [ [: `'\010'; s :] -> skip_indent s - | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s } - | [: x = backslash :] -> store x - | [: `c when not strict :] -> do { store '\\'; store c } - | [: :] -> failwith "invalid string token" ]; - - value char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else match Stream.of_string s with parser - [ [: `'\\'; x = backslash :] -> x - | [: :] -> failwith "invalid char token" ]; - - value string ?strict s = - let buf = Buffer.create 23 in - let store = Buffer.add_char buf in - let rec parse = parser - [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s - | [: `c; s :] -> do { store c; parse s } - | [: :] -> Buffer.contents buf ] - in parse (Stream.of_string s); -end; diff --git a/camlp4/Camlp4/Struct/Token.mli b/camlp4/Camlp4/Struct/Token.mli deleted file mode 100644 index d3e866a3..00000000 --- a/camlp4/Camlp4/Struct/Token.mli +++ /dev/null @@ -1,35 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc; - -module Eval : sig - value char : string -> char; - (** Convert a char token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if an - incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)] - returns [c] *) - - value string : ?strict:unit -> string -> string; - (** [Taken.Eval.string strict s] - Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if [strict] and an - incorrect backslash sequence is found; - [Token.Eval.string strict (String.escaped s)] returns [s] *) -end; diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml deleted file mode 100644 index ecc64311..00000000 --- a/camlp4/Camlp4Bin.ml +++ /dev/null @@ -1,325 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -open Camlp4; -open PreCast.Syntax; -open PreCast; -open Format; -module CleanAst = Camlp4.Struct.CleanAst.Make Ast; -module SSet = Set.Make String; - -value pa_r = "Camlp4OCamlRevisedParser"; -value pa_rr = "Camlp4OCamlReloadedParser"; -value pa_o = "Camlp4OCamlParser"; -value pa_rp = "Camlp4OCamlRevisedParserParser"; -value pa_op = "Camlp4OCamlParserParser"; -value pa_g = "Camlp4GrammarParser"; -value pa_m = "Camlp4MacroParser"; -value pa_qb = "Camlp4QuotationCommon"; -value pa_q = "Camlp4QuotationExpander"; -value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; -value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; -value pa_l = "Camlp4ListComprehension"; - -open Register; - -value dyn_loader = ref (fun []); -value rcall_callback = ref (fun () -> ()); -value loaded_modules = ref SSet.empty; -value add_to_loaded_modules name = - loaded_modules.val := SSet.add name loaded_modules.val; - -value (objext,libext) = - if DynLoader.is_native then (".cmxs",".cmxs") - else (".cmo",".cma"); - -value rewrite_and_load n x = - let dyn_loader = dyn_loader.val () in - let find_in_path = DynLoader.find_in_path dyn_loader in - let real_load name = do { - add_to_loaded_modules name; - DynLoader.load dyn_loader name - } in - let load = List.iter begin fun n -> - if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () - else begin - add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ objext); - end - end in - do { - match (n, String.lowercase x) with - [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] - | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] - | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] - | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] - | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] - | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] - | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] - | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q] - | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] - | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] - | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] - | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] - | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] - | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] - (* map is now an alias of fold since fold handles map too *) - | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"] - | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] - | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] - | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] - | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] - | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> - Register.enable_ocamlr_printer () - | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> - Register.enable_ocaml_printer () - | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") -> - Register.enable_dump_ocaml_ast_printer () - | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") -> - Register.enable_dump_camlp4_ast_printer () - | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> - load ["Camlp4AutoPrinter"] - | _ -> - let y = "Camlp4"^n^"/"^x^objext in - real_load (try find_in_path y with [ Not_found -> x ]) ]; - rcall_callback.val (); - }; - -value print_warning = eprintf "%a:\n%s@." Loc.print; - -value rec parse_file dyn_loader name pa getdir = - let directive_handler = Some (fun ast -> - match getdir ast with - [ Some x -> - match x with - [ (_, "load", s) -> do { rewrite_and_load "" s; None } - | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None } - | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) - | (_, "default_quotation", s) -> do { Quotation.default.val := s; None } - | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ] - | None -> None ]) in - let loc = Loc.mk name - in do { - current_warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name; - let cs = Stream.of_channel ic; - let clear () = if name = "-" then () else close_in ic; - let phr = - try pa ?directive_handler loc cs - with x -> do { clear (); raise x }; - clear (); - phr - }; - -value output_file = ref None; - -value process dyn_loader name pa pr clean fold_filters getdir = - let ast = parse_file dyn_loader name pa getdir in - let ast = fold_filters (fun t filter -> filter t) ast in - let ast = clean ast in - pr ?input_file:(Some name) ?output_file:output_file.val ast; - -value gind = - fun - [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value gimd = - fun - [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value process_intf dyn_loader name = - process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf - (new CleanAst.clean_ast)#sig_item - AstFilters.fold_interf_filters gind; -value process_impl dyn_loader name = - process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem - (new CleanAst.clean_ast)#str_item - AstFilters.fold_implem_filters gimd; - -value just_print_the_version () = - do { printf "%s@." Camlp4_config.version; exit 0 }; - -value print_version () = - do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 }; - -value print_stdlib () = - do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 }; - -value usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options]\n\ -Options:\n\ -.ml Parse this implementation file\n\ -.mli Parse this interface file\n\ -.%s Load this module inside the Camlp4 core@." -(if DynLoader.is_native then "cmxs " else "(cmo|cma)") -; - Options.print_usage_list ini_sl; - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:@."; - Options.print_usage_list ext_sl; - } - else (); - }; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete\n\ -You should give the -noassert option to the ocaml compiler instead.@."; - }; - -type file_kind = - [ Intf of string - | Impl of string - | Str of string - | ModuleImpl of string - | IncludeDir of string ]; - -value search_stdlib = ref True; -value print_loaded_modules = ref False; -value (task, do_task) = - let t = ref None in - let task f x = - let () = Camlp4_config.current_input_file.val := x in - t.val := Some (if t.val = None then (fun _ -> f x) - else (fun usage -> usage ())) in - let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in - (task, do_task); -value input_file x = - let dyn_loader = dyn_loader.val () in - do { - rcall_callback.val (); - match x with - [ Intf file_name -> task (process_intf dyn_loader) file_name - | Impl file_name -> task (process_impl dyn_loader) file_name - | Str s -> - begin - let (f, o) = Filename.open_temp_file "from_string" ".ml"; - output_string o s; - close_out o; - task (process_impl dyn_loader) f; - at_exit (fun () -> Sys.remove f); - end - | ModuleImpl file_name -> rewrite_and_load "" file_name - | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; - rcall_callback.val (); - }; - -value initial_spec_list = - [("-I", Arg.String (fun x -> input_file (IncludeDir x)), - " Add directory in search patch for object files."); - ("-where", Arg.Unit print_stdlib, - "Print camlp4 library directory and exit."); - ("-nolib", Arg.Clear search_stdlib, - "No automatic search for object files in library directory."); - ("-intf", Arg.String (fun x -> input_file (Intf x)), - " Parse as an interface, whatever its extension."); - ("-impl", Arg.String (fun x -> input_file (Impl x)), - " Parse as an implementation, whatever its extension."); - ("-str", Arg.String (fun x -> input_file (Str x)), - " Parse as an implementation."); - ("-unsafe", Arg.Set Camlp4_config.unsafe, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Camlp4_config.verbose, - "More verbose in parsing errors."); - ("-loc", Arg.Set_string Loc.name, - " Name of the location variable (default: " ^ Loc.name.val ^ ")."); - ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x), - " Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> output_file.val := Some x), - " Output on instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit."); - ("-version", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-vnum", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-no_quot", Arg.Clear Camlp4_config.quotations, - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); - ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules."); - ("-parser", Arg.String (rewrite_and_load "Parsers"), - " Load the parser Camlp4Parsers/.cm(o|a|xs)"); - ("-printer", Arg.String (rewrite_and_load "Printers"), - " Load the printer Camlp4Printers/.cm(o|a|xs)"); - ("-filter", Arg.String (rewrite_and_load "Filters"), - " Load the filter Camlp4Filters/.cm(o|a|xs)"); - ("-ignore", Arg.String ignore, "ignore the next argument"); - ("--", Arg.Unit ignore, "Deprecated, does nothing") -]; - -Options.init initial_spec_list; - -value anon_fun name = - input_file - (if Filename.check_suffix name ".mli" then Intf name - else if Filename.check_suffix name ".ml" then Impl name - else if Filename.check_suffix name objext then ModuleImpl name - else if Filename.check_suffix name libext then ModuleImpl name - else raise (Arg.Bad ("don't know what to do with " ^ name))); - -value main argv = - let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in - try do { - let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val - ~camlp4_stdlib:search_stdlib.val (); - dyn_loader.val := fun () -> dynloader; - let call_callback () = - Register.iter_and_take_callbacks - (fun (name, module_callback) -> - let () = add_to_loaded_modules name in - module_callback ()); - call_callback (); - rcall_callback.val := call_callback; - match Options.parse anon_fun argv with - [ [] -> () - | ["-help"|"--help"|"-h"|"-?" :: _] -> usage () - | [s :: _] -> - do { eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage@."; - exit 2 } ]; - do_task usage; - call_callback (); - if print_loaded_modules.val then do { - SSet.iter (eprintf "%s@.") loaded_modules.val; - } else () - } - with - [ Arg.Bad s -> do { eprintf "Error: %s\n" s; - eprintf "Use option -help for usage@."; - exit 2 } - | Arg.Help _ -> usage () - | exc -> do { eprintf "@[%a@]@." ErrorHandler.print exc; exit 2 } ]; - -main Sys.argv; diff --git a/camlp4/Camlp4Filters/Camlp4AstLifter.ml b/camlp4/Camlp4Filters/Camlp4AstLifter.ml deleted file mode 100644 index cc594aac..00000000 --- a/camlp4/Camlp4Filters/Camlp4AstLifter.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4AstLifter"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - - module MetaLoc = struct - module Ast = Ast; - value meta_loc_patt _loc _ = <:patt< loc >>; - value meta_loc_expr _loc _ = <:expr< loc >>; - end; - module MetaAst = Ast.Meta.Make MetaLoc; - - register_str_item_filter (fun ast -> - let _loc = Ast.loc_of_str_item ast in - <:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>); - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml deleted file mode 100644 index 3cf570c0..00000000 --- a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml +++ /dev/null @@ -1,68 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4ExceptionTracer"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - open Ast; - - value add_debug_expr e = - (* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *) - let _loc = Ast.loc_of_expr e in - let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in - <:expr< - try $e$ - with - [ Stream.Failure | Exit as exc -> raise exc - | exc -> do { - if Debug.mode "exc" then - Format.eprintf $`str:msg$ (Printexc.to_string exc) else (); - raise exc - } ] >>; - - value rec map_match_case = - fun - [ <:match_case@_loc< $m1$ | $m2$ >> -> - <:match_case< $map_match_case m1$ | $map_match_case m2$ >> - | <:match_case@_loc< $p$ when $w$ -> $e$ >> -> - <:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >> - | m -> m ]; - - value filter = object - inherit Ast.map as super; - method expr = fun - [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >> - | x -> super#expr x ]; - method str_item = fun - [ <:str_item< module Debug = $_$ >> as st -> st - | st -> super#str_item st ]; - end; - - register_str_item_filter filter#str_item; - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml deleted file mode 100644 index 205afa92..00000000 --- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml +++ /dev/null @@ -1,609 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4FoldGenerator"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - module StringMap = Map.Make String; - open Ast; - - value _loc = Loc.ghost; - - value sf = Printf.sprintf; - - value xik i k = - let i = - if i < 0 then assert False - else if i = 0 then "" - else sf "_i%d" i - in - let k = - if k < 1 then assert False - else if k = 1 then "" - else sf "_k%d" k - in - sf "_x%s%s" i k; - value exik i k = <:expr< $lid:xik i k$ >>; - value pxik i k = <:patt< $lid:xik i k$ >>; - value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>; - value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>; - - value xs s = "_x_" ^ s; - value xsk = sf "_x_%s_%d"; - value exsk s k = <:expr< $lid:xsk s k$>>; - - value rec apply_expr accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_expr x - in apply_expr <:expr< $accu$ $x$ >> xs ]; - - value rec apply_patt accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_patt x - in apply_patt <:patt< $accu$ $x$ >> xs ]; - - value rec apply_ctyp accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_ctyp x - in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; - - value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; - - value list_init f n = - let rec self m = - if m = n then [] - else [f m :: self (succ m)] - in self 0; - - value rec lid_of_ident sep = - fun - [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s - | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2 - | _ -> assert False ]; - - type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool); - - value builtin_types = - let tyMap = StringMap.empty in - let tyMap = - let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in - List.fold_right - (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False)) - abstr tyMap - in - let tyMap = - let concr = - [("bool", <:ident>, [], <:ctyp< [ False | True ] >>, False); - ("list", <:ident>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False); - ("option", <:ident